Scaled In Cell Charting

I was using In Cell Charting, but it didn’t quite look right. I needed each chart to be scaled over a range that encompasses all the values. In the following screen, cell G4 seems to fluctuate wildly. But if these were all expense classifications, it overstates the importance of those fluctuations.

Why did expenses rise or fall over those five periods? Column F tells you that only line 3 and line 6 would have a demonstrable impact on expenses as a whole. Cell F3 has this formula

=linechart(A3:E3,203,$A$3:$E$8)

and it’s copied down. Here’s the revised code:

Function LineChart(Points As Range, Color As Long, Optional VerticalScale As Range) As String
   
    Dim rCaller As Range
    Dim avNames() As Variant
    Dim i As Long, j As Long, k As Long
    Dim dMin As Double, dMax As Double, dScaleMin As Double, dScaleMax As Double
    Dim shp As Shape
    Dim rScale As Range
    Dim dEffWidth As Double, dEffHeight As Double, dEffBottom As Double, dEffLeft As Double
   
    Const lMARGIN As Long = 2
   
    Set rCaller = Application.Caller
 
    ShapeDelete rCaller
   
    ‘If VerticalScale Is Nothing Then
   ‘    Set rScale = Points
   ‘Else
   ‘    Set rScale = VerticalScale
   ‘End If
   
    If VerticalScale Is Nothing Then
        Set rScale = Points
    Else
        If Not Application.Intersect(Points, VerticalScale) Is Nothing Then
            If Application.Intersect(Points, VerticalScale).Address = _
                Points.Address Then
               
                Set rScale = VerticalScale
            Else
                Set rScale = Application.Union(Points, VerticalScale)
            End If
        Else
            Set rScale = Application.Union(Points, VerticalScale)
        End If
    End If
 
    With Application.WorksheetFunction
        dMin = .Min(Points)
        dMax = .Max(Points)
        dScaleMin = .Min(rScale)
        dScaleMax = .Max(rScale)
    End With
   
    dEffWidth = rCaller.Width – (lMARGIN * 2)
    dEffHeight = rCaller.Height – (lMARGIN * 2)
    dEffBottom = rCaller.Top + lMARGIN + dEffHeight
    dEffLeft = rCaller.Left + lMARGIN
   
    With rCaller.Worksheet.Shapes
        For i = 0 To Points.Count – 2
           
            Set shp = .AddLine( _
                dEffLeft + (i * (dEffWidth) / (Points.Count – 1)), _
                dEffBottom – (dEffHeight * (Points(, i + 1) – dScaleMin + 1) / (dScaleMax – dScaleMin + 1)), _
                dEffLeft + ((i + 1) * (dEffWidth) / (Points.Count – 1)), _
                dEffBottom – (dEffHeight * (Points(, i + 2) – dScaleMin + 1) / (dScaleMax – dScaleMin + 1)))
 
            On Error Resume Next
                j = 0
                j = UBound(avNames) + 1
            On Error GoTo 0
           
            ReDim Preserve avNames(j)
            avNames(j) = shp.Name
        Next
 
        With rCaller.Worksheet.Shapes.Range(avNames)
            .Group
            .Line.ForeColor.RGB = Abs(Color)
        End With
 
    End With
 
    LineChart = “”
   
End Function
 
Sub ShapeDelete(rngSelect As Range)
    Dim rng As Range, shp As Shape, blnDelete As Boolean
 
    For Each shp In rngSelect.Worksheet.Shapes
        blnDelete = False
        Set rng = Intersect(Range(shp.TopLeftCell, shp.BottomRightCell), rngSelect)
        If Not rng Is Nothing Then
            If rng.Address = Range(shp.TopLeftCell, shp.BottomRightCell).Address Then blnDelete = True
        End If
 
        If blnDelete Then shp.Delete
    Next
End Sub

You can omit the last argument and it should work as it did before. I think there may be some problems if you define a VerticalScale that has no bearing on the data. I should probably check that Points is contained in VerticalScale. The potential problem is that if the Shape object is drawn outside of the cell, it won’t get deleted properly on recalc.

Update: I was right, it was a disaster. I changed the code, but left the original IF block in there, just commented out. I don’t know if that fix is really desirable though. Your thoughts?

Posted in Uncategorized

34 thoughts on “Scaled In Cell Charting

  1. If the location of the shape cannot be counted on for identification of shapes to delete, you could do something creative with the shape name. Give the shape a descriptive name, something that includes the address, like “InCell_A1_Line”. Then your code can look for the range in the shape name (between underscore characters), compare this range to the range called out in the LineChart formula.

  2. Here’s how you name the shape:

            With rCaller.Worksheet.Shapes.Range(avNames)
                .Group
                .Line.ForeColor.RGB = Abs(Color)
            End With
           
            rCaller.Worksheet.Shapes(rCaller.Worksheet.Shapes.Count).Name = _
                “InCell_” & rCaller.Address(False, False) & “_Line”
     
        End With
     
        LineChart = “”
       
    End Function

    and here’s how you delete the shape:

    Sub ShapeDelete(rngSelect As Range)
        Dim rng As Range, shp As Shape, blnDelete As Boolean
        Dim sShp As String, sCell As String
     
        For Each shp In rngSelect.Worksheet.Shapes
            blnDelete = False
            sShp = shp.Name
            sCell = Mid$(sShp, InStr(sShp, “_”) + 1)
            sCell = Left$(sCell, InStr(sCell, “_”) – 1)
            Set rng = Intersect(rngSelect, rngSelect.Worksheet.Range(sCell))
            If Not rng Is Nothing Then
                If rng.Address = rngSelect.Worksheet.Range(sCell).Address Then blnDelete = True
            End If
     
            If blnDelete Then shp.Delete
        Next
       
    End Sub

    I don’t remember if the pre tabs work here.

    Editor: I put the vb-in-brackets around your code.

  3. Now I remember, the pre tags don’t work here. At least I had no greeater thans and less thans to mess it up.

    By the way, I meant to call this a neat trick, but then I crashed Excel five times in like 15 minutes. Kind of reminds me of Excel 5 on Windows 3.1.

  4. I too have found shapes-from-udf (in cell charting) crashes Excel…
    In the past, I resorted to a button for drawing the graphics.

    I recall a suggestion that the UDFs register their cell as dirty, so that at timed intervals, the dirty cells are redrawn.

  5. Comment Deleted. It was an Excel question that had nothing to do with this post and was posted to at least one other Excel blog today.

  6. Dick –

    Thanks for cleaning up after my code. I know I read the bost about the VB tags, but ss I have to reboot my flash memory. If that PLAIN TEXT thing looked more like a link, I might have clicked on one.

    Rob –

    I tried to find the post about the UDF marking the cell (I vaguely remember something like that, but there’s the memory issue again). Do you know how that works?

  7. Jon,

    Re UDF marking the cell. The UDF takes the parameters, adds the Caller and some sort of task ID, puts it all in UDT/array and adds it to a global collection/array – effectively creating a task list. The _Calculate event goes through the global collection and processes the tasks. The difference between the two approaches is that the ‘pure’ UDF does its stuff when you F2+Enter, while the mark/calc method only does its stuff on a sheet/book recalc.

  8. Dick: Trying to think of a practical application for what I do. But I am not understanding the importance of having a relative reference in the first term then an absolute reference to the entire array row upon row in the last term. What is this telling me about the data?

  9. Doco –

    The first range is what provides the data for that row’s chart. The overall range is what the code searches for the min and max for all of the charts, so they all use the same scale.

  10. Hi Jon,

    I found error for the statement below, is the second line wrongly displayed?

    Thanks

    rCaller.Worksheet.Shapes(rCaller.Worksheet.Shapes.Count).Name = _
                “InCell_” & rCaller.Address(False, False) & “_Line”
  11. That was to be expected. It does not display as I intended
    Emily, just delete twice this part:
    amp;
    and it should work

  12. Well, I spent 3 seconds following up on doco’s comment about decimal fractions. The charts seemed to update fine, and I was copying the data range and pasting the values (I’d used a formula with RAND() to get fractional values) when Excel crashed.

    My conclusion: using a UDF is not nearly stable enough. You can just as easily run the code off of a worksheet_change event. Keep the formula in the cell, but take out the drawing routine and leave only the LineChart = “” piece. Then in the event procedure, parse the formula, and run the regular code.

    When I get a minute I’ll do a proof of concept.

  13. This incorporates two enhancements.

    1. It runs off the Worksheet_Calculate event

    This has proven to be way more stable.

    2. It works better for small fractions

    The other code had a +1 in the formulas that determined the Y coordinates of the endpoints of each line. Adding 1 helped when the values are large, but when they are small, 1 was greater than the Y axis range. I changed this 1 to dScaleMargin, which was a small fraction of the Y axis range.

    Code in regular module:

    ‘——————————-
    Function LineChart(Points As Range, Color As Long, Optional VerticalScale As Range) As String

      LineChart = “”

    End Function
    ‘——————————-
    Sub ShapeDelete(rngSelect As Range)
      Dim rng As Range, shp As Shape, blnDelete As Boolean
      Dim sShp As String, sCell As String

      ‘    For Each shp In rngSelect.Worksheet.Shapes
     ‘        blnDelete = False
     ‘        Set rng = Intersect(Range(shp.TopLeftCell, shp.BottomRightCell), rngSelect)
     ‘        If Not rng Is Nothing Then
     ‘            If rng.Address = Range(shp.TopLeftCell, shp.BottomRightCell).Address Then blnDelete = True
     ‘        End If
     
     ‘        If blnDelete Then shp.Delete
     ‘    Next

      For Each shp In rngSelect.Worksheet.Shapes
        blnDelete = False
        sShp = shp.Name
        sCell = Mid$(sShp, InStr(sShp, “_”) + 1)
        sCell = Left$(sCell, InStr(sCell, “_”) – 1)
        Set rng = Intersect(rngSelect, rngSelect.Worksheet.Range(sCell))
        If Not rng Is Nothing Then
          If rng.Address = rngSelect.Worksheet.Range(sCell).Address Then blnDelete = True
        End If

        If blnDelete Then shp.Delete
      Next

    End Sub
    ‘——————————-
    Sub DrawLineChart()
      Dim rFormulas As Range
      Dim rArea As Range
      Dim sFormula As String
      Dim aFormula As Variant
      Dim Points As Range
      Dim Color As Long
      Dim VerticalScale As Range
      Dim rCaller As Range
      Dim avNames() As Variant
      Dim i As Long, j As Long, k As Long
      Dim dMin As Double, dMax As Double, dScaleMin As Double, dScaleMax As Double
      Dim shp As Shape
      Dim rScale As Range
      Dim dEffWidth As Double, dEffHeight As Double, dEffBottom As Double, dEffLeft As Double
      Dim dScaleMargin As Double

      Const lMARGIN As Long = 2

      Application.EnableEvents = False
     
      Set rFormulas = ActiveSheet.UsedRange.SpecialCells(xlCellTypeFormulas)

      For Each rArea In rFormulas.Areas

        For Each rCaller In rArea.Cells

          sFormula = UCase$(rCaller.Formula)

          If Left$(sFormula, 11) = “=LINECHART(“ Then

            sFormula = Mid$(sFormula, 12)
            sFormula = Left$(sFormula, Len(sFormula) – 1)
            aFormula = Split(sFormula, “,”)

            Set Points = ActiveSheet.Range(aFormula(0))
            Color = CLng(aFormula(1))
            If UBound(aFormula) > 1 Then
              Set VerticalScale = ActiveSheet.Range(aFormula(2))
            End If

            ShapeDelete rCaller

            If VerticalScale Is Nothing Then
              Set rScale = Points
            Else
              If Not Application.Intersect(Points, VerticalScale) Is Nothing Then
                If Application.Intersect(Points, VerticalScale).Address = _
                    Points.Address Then

                  Set rScale = VerticalScale
                Else
                  Set rScale = Application.Union(Points, VerticalScale)
                End If
              Else
                Set rScale = Application.Union(Points, VerticalScale)
              End If
            End If

            With Application.WorksheetFunction
              dMin = .Min(Points)
              dMax = .Max(Points)
              dScaleMin = .Min(rScale)
              dScaleMax = .Max(rScale)
            End With
            dScaleMargin = (dScaleMax – dScaleMin) / 50

            dEffWidth = rCaller.Width – (lMARGIN * 2)
            dEffHeight = rCaller.Height – (lMARGIN * 2)
            dEffBottom = rCaller.Top + lMARGIN + dEffHeight
            dEffLeft = rCaller.Left + lMARGIN

            With rCaller.Worksheet.Shapes
              For i = 0 To Points.Count – 2

                Set shp = .AddLine( _
                    dEffLeft + (i * (dEffWidth) / (Points.Count – 1)), _
                    dEffBottom – (dEffHeight * (Points(, i + 1) – dScaleMin + dScaleMargin) / _
                        (dScaleMax – dScaleMin + 2 * dScaleMargin)), _
                    dEffLeft + ((i + 1) * (dEffWidth) / (Points.Count – 1)), _
                    dEffBottom – (dEffHeight * (Points(, i + 2) – dScaleMin + dScaleMargin) / _
                        (dScaleMax – dScaleMin + 2 * dScaleMargin)))

                On Error Resume Next
                j = 0
                j = UBound(avNames) + 1
                On Error GoTo 0

                ReDim Preserve avNames(j)
                avNames(j) = shp.Name
              Next

              With rCaller.Worksheet.Shapes.Range(avNames)
                .Group
                .Line.ForeColor.RGB = Abs(Color)
              End With

              ” if this line contains funny stuff replace with plain ampersands
             rCaller.Worksheet.Shapes(rCaller.Worksheet.Shapes.Count).Name = _
                “InCell_” & rCaller.Address(False, False) & “_Line”

              Erase avNames
              Set rCaller = Nothing
              Set Points = Nothing
              Set rScale = Nothing
              Set VerticalScale = Nothing
            End With
          End If
        Next
      Next

      Application.EnableEvents = True
     
    End Sub
    ‘——————————-

    Code in worksheet module:

    Private Sub Worksheet_Change(ByVal Target As Range)
      DrawLineChart
    End Sub
  14. Quick question… when you actually create your line object (line of code beginning with Set Shp =) why do you use “points(,i+1)”? This forces you to use horizontal tables of data. If you just delete the comma, the function works on vertical tables as well (at least it did in the few cases I tried).

    Kevin

  15. Kevin –

    That’s the flexibiity of it. Generally these sparklines are envisioned as describing the rows of a table, so the data for each line is arranged by rows. However, if you had a different requirement, you could change the code to use data in columns.

  16. (slaps forehead) But why not build flexibility into the code?

    First point, since I can’t usually remember what’s the default property of an object, I’ve gotten into the practice of always stating all of my properties. So

    Points(, i + 1)

    should really be

    Points(, i + 1).Value

    However, to allow for horizontally or vertically oriented data, you could use

    Points.Cells(i + 1).Value

    Upstream of this, of course, you need to make sure that the range Points is a on dimensional range.

  17. Ok, points.cells makes more sense. Another question, is there any way to get the line to go across merged cells? Where is the width pulled from?

    Kevin

  18. Got it. Change the lines for width and height to this:
    dEffWidth = rCaller.MergeArea.Width – (lMARGIN * 2)
    dEffHeight = rCaller.MergeArea.Height – (lMARGIN * 2)

    Now it will put the line across a merged cell. Next, I’m going to try to get it to draw a vertical line for vertical data. Shouldn’t be too hard… (famous last words!)

    Kevin

  19. Don’t know if this will help the excel crashing, but before you delete a shape, move it to with in the cell border. I’ve been working on putting labels at specific points along the line. If those labels protrude into adjacent cells, excel crashes when it tries to delete them (not while stepping through though… annoying!). Solution was to move each label to the left top edge of the cell, then delete. I’ll probably shrink it’s width to handle small cells, but it seems to work. I wonder if this were applied to the line itself Excel wouldn’t crash. I don’t know.

    Kevin

  20. Hmmm, didn’t try that. Not moving the shapes, I doubt that’s the issue. I think Excel just needs the short break that moving the shapes provides. I’ll try using DoEvents, probably after each shape is made and after each is deleted.

  21. Bonjour,

    here is a modest contribution to this post that helped me so much.
    another tool on the “in cell” chartind UDF subject, the bullet chart as explained here : http://www.exceluser.com/explore/bullet.htm

    Thaks to a

    Function BulletChart(Mesure As Double, Target As Double, Maxi As Double, Optional Good As Double, Optional Bad As Double) As String
    Const Margin = 2
    Const Thick = 1.5
    Dim rng As Range
    Dim arr() As Variant
    Dim sng As Single, RapTM As Single
    Dim HBckgrnd As Single, HMesure As Single, HTarget As Single
    Dim TopBkgrd As Single, TopMesure As Single, TopTarget As Single
    Dim StrtMesure As Single, StrtTarget As Single, StrtGood As Single, StrtAverage As Single, StrtBad As Single
    Dim EndBckgrd As Single, EndMesure As Single, EndTarget As Single, EndBad As Single, EndGood As Single, EndAverage As Single
    Dim ShpBad As Shape, ShpGood As Shape, ShpAverage As Shape, ShpTarget As Shape, ShpMesure As Shape
    Dim WidthCell As Single

    Set rng = Application.Caller
    ShapeDelete rng

    With rng.Worksheet.Shapes
    WidthCell = rng.MergeArea.Width
    HBckgrnd = (rng.Height – (Margin * 2))
    HMesure = (rng.Height * 0.5 – Margin * 2)
    HTarget = (rng.Height * 0.9 – Margin * 2)
    TopBkgrd = rng.Top + Margin
    TopMesure = rng.Top + Margin + rng.Height * 0.25
    TopTarget = rng.Top + Margin + rng.Height * 0.05
    StrtMesure = Margin + rng.Left
    StrtTarget = Margin + rng.Left + (WidthCell * (Target / Maxi))
    StrtGood = StrtMesure
    StrtAverage = Margin + rng.Left + (WidthCell * (Good / Maxi))
    StrtBad = Margin + rng.Left + (WidthCell * (Bad / Maxi))
    EndBad = rng.Left + WidthCell – (Margin) – StrtBad
    EndGood = rng.Left + WidthCell – (Margin) – StrtGood
    EndAverage = rng.Left + WidthCell – (Margin) – StrtAverage
    EndMesure = Margin + rng.Left + (WidthCell * (Mesure / Maxi)) – StrtMesure
    EndTarget = Margin + rng.Left + (WidthCell * (Target / Maxi)) + Thick – StrtTarget

    ReDim arr(1 To 5)

    Set ShpGood = .AddShape(msoShapeRectangle, StrtGood, TopBkgrd, EndGood, HBckgrnd)
    ShpGood.Line.Visible = msoFalse
    ShpGood.Fill.ForeColor.RGB = 11513775
    arr(1) = ShpGood.Name

    Set ShpBad = .AddShape(msoShapeRectangle, StrtBad, TopBkgrd, EndBad, HBckgrnd)
    ShpBad.Line.Visible = msoFalse
    ShpBad.Fill.ForeColor.RGB = 13158600
    arr(2) = ShpBad.Name

    Set ShpAverage = .AddShape(msoShapeRectangle, StrtAverage, TopBkgrd, EndAverage, HBckgrnd)
    ShpAverage.Line.Visible = msoFalse
    ShpAverage.Fill.ForeColor.RGB = 15132390
    arr(3) = ShpAverage.Name

    Set ShpMesure = .AddShape(msoShapeRectangle, StrtMesure, TopMesure, EndMesure, HMesure)
    ShpMesure.Line.Visible = msoFalse
    ShpMesure.Fill.ForeColor.RGB = 0
    arr(4) = ShpMesure.Name

    Set ShpTarget = .AddShape(msoShapeRectangle, StrtTarget, TopTarget, EndTarget, HTarget)
    ShpTarget.Line.Visible = msoFalse
    ShpTarget.Fill.ForeColor.RGB = 203
    arr(5) = ShpTarget.Name

    rng.Worksheet.Shapes.Range(arr).Group

    End With

    BulletChart = “”
    End Function

    Sub ShapeDelete(rngSelect As Range)
    Dim rng As Range, shp As Shape, blnDelete As Boolean

    For Each shp In rngSelect.Worksheet.Shapes
    blnDelete = False
    Set rng = Intersect(Range(shp.TopLeftCell, shp.BottomRightCell), rngSelect)
    If Not rng Is Nothing Then
    If rng.Address = Range(shp.TopLeftCell, shp.BottomRightCell).Address Then blnDelete = True
    End If

    If blnDelete Then shp.Delete
    Next
    End Sub

  22. Bonjour,

    here is a modest contribution to this post that helped me so much.
    another tool on the “in cell” chartind UDF subject, the bullet chart as explained here : http://www.exceluser.com/explore/bullet.htm

    Thanks to all contributors…

    Function BulletChart(Mesure As Double, Target As Double, Maxi As Double, Optional Good As Double, Optional Bad As Double) As String
    Const Margin = 2
    Const Thick = 1.5
    Dim rng As Range
    Dim arr() As Variant
    Dim sng As Single, RapTM As Single
    Dim HBckgrnd As Single, HMesure As Single, HTarget As Single
    Dim TopBkgrd As Single, TopMesure As Single, TopTarget As Single
    Dim StrtMesure As Single, StrtTarget As Single, StrtGood As Single, StrtAverage As Single, StrtBad As Single
    Dim EndBckgrd As Single, EndMesure As Single, EndTarget As Single, EndBad As Single, EndGood As Single, EndAverage As Single
    Dim ShpBad As Shape, ShpGood As Shape, ShpAverage As Shape, ShpTarget As Shape, ShpMesure As Shape
    Dim WidthCell As Single

    Set rng = Application.Caller
    ShapeDelete rng

    With rng.Worksheet.Shapes
    WidthCell = rng.MergeArea.Width
    HBckgrnd = (rng.Height – (Margin * 2))
    HMesure = (rng.Height * 0.5 – Margin * 2)
    HTarget = (rng.Height * 0.9 – Margin * 2)
    TopBkgrd = rng.Top + Margin
    TopMesure = rng.Top + Margin + rng.Height * 0.25
    TopTarget = rng.Top + Margin + rng.Height * 0.05
    StrtMesure = Margin + rng.Left
    StrtTarget = Margin + rng.Left + (WidthCell * (Target / Maxi))
    StrtGood = StrtMesure
    StrtAverage = Margin + rng.Left + (WidthCell * (Good / Maxi))
    StrtBad = Margin + rng.Left + (WidthCell * (Bad / Maxi))
    EndBad = rng.Left + WidthCell – (Margin) – StrtBad
    EndGood = rng.Left + WidthCell – (Margin) – StrtGood
    EndAverage = rng.Left + WidthCell – (Margin) – StrtAverage
    EndMesure = Margin + rng.Left + (WidthCell * (Mesure / Maxi)) – StrtMesure
    EndTarget = Margin + rng.Left + (WidthCell * (Target / Maxi)) + Thick – StrtTarget

    ReDim arr(1 To 5)

    Set ShpGood = .AddShape(msoShapeRectangle, StrtGood, TopBkgrd, EndGood, HBckgrnd)
    ShpGood.Line.Visible = msoFalse
    ShpGood.Fill.ForeColor.RGB = 11513775
    arr(1) = ShpGood.Name

    Set ShpBad = .AddShape(msoShapeRectangle, StrtBad, TopBkgrd, EndBad, HBckgrnd)
    ShpBad.Line.Visible = msoFalse
    ShpBad.Fill.ForeColor.RGB = 13158600
    arr(2) = ShpBad.Name

    Set ShpAverage = .AddShape(msoShapeRectangle, StrtAverage, TopBkgrd, EndAverage, HBckgrnd)
    ShpAverage.Line.Visible = msoFalse
    ShpAverage.Fill.ForeColor.RGB = 15132390
    arr(3) = ShpAverage.Name

    Set ShpMesure = .AddShape(msoShapeRectangle, StrtMesure, TopMesure, EndMesure, HMesure)
    ShpMesure.Line.Visible = msoFalse
    ShpMesure.Fill.ForeColor.RGB = 0
    arr(4) = ShpMesure.Name

    Set ShpTarget = .AddShape(msoShapeRectangle, StrtTarget, TopTarget, EndTarget, HTarget)
    ShpTarget.Line.Visible = msoFalse
    ShpTarget.Fill.ForeColor.RGB = 203
    arr(5) = ShpTarget.Name

    rng.Worksheet.Shapes.Range(arr).Group

    End With

    BulletChart = “”
    End Function

    Sub ShapeDelete(rngSelect As Range)
    Dim rng As Range, shp As Shape, blnDelete As Boolean

    For Each shp In rngSelect.Worksheet.Shapes
    blnDelete = False
    Set rng = Intersect(Range(shp.TopLeftCell, shp.BottomRightCell), rngSelect)
    If Not rng Is Nothing Then
    If rng.Address = Range(shp.TopLeftCell, shp.BottomRightCell).Address Then blnDelete = True
    End If

    If blnDelete Then shp.Delete
    Next
    End Sub

  23. I think it would make sense to replace:

        If VerticalScale Is Nothing Then
            Set rScale = Points
        Else
            If Not Application.Intersect(Points, VerticalScale) Is Nothing Then
                If Application.Intersect(Points, VerticalScale).Address = _
                    Points.Address Then
                   
                    Set rScale = VerticalScale
                Else
                    Set rScale = Application.Union(Points, VerticalScale)
                End If
            Else
                Set rScale = Application.Union(Points, VerticalScale)
            End If
        End If

    with:

    Set rScale = Application.Union(Points, VerticalScale)
  24. Oops. I meant, replace it with:

    If VerticalScale Is Nothing Then
        Set rScale = Points
    Else
        Set rScale = Application.Union(Points, VerticalScale)
    End If

    All of the other conditions are meaningless, they come out to the same thing as a simple Union.

  25. Come to think of it, in the first post, the whole complex ShapeDelete procedure can be replaced with:

    Sub ShapeDelete(rngSelect As Range)
        Dim shp As Shape
     
        For Each shp In rngSelect.Worksheet.Shapes
            If rngSelect.Address = Range(shp.TopLeftCell, shp.BottomRightCell).Address Then shp.Delete
        Next
    End Sub

    The original (complex) procedure first looks for all shapes intersecting rngSelect, then verifies that they are completely contained in rngSelect, then sets a boolean flag, and finally deletes the shape if flagged. Instead, just delete any shape that is contained in rngSelect. Much simpler, and does the same thing.

  26. You don’t want to oversimplify this deletion routine. What if the user accidentally dragged a shape off of its original location? What if a different but important shape happens to be located in the range being cleared? These are why labeling is important. In fact, in one of my iterations (which I may not have posted), the shape name includes the name of the cell it is supposed to cover. The code checkes this name, not the actual top left cell, prior to deletion.

  27. Here’s an outstanding rendition of sparklines by Excel MVP Fernando Cinquegrani:

    http://www.prodomosua.eu/zips/sparklines.xls

    He draws a normal-sized and normal-featured Excel chart in a far away region of the sheet, copies the underlying range, and uses Paste Link Picture to put a dynamic shrunken image of the chart over the desired cell.

    It will fail in 2007 because doing a print preview of a paste linked region that shows a chart hoses the chart. But in versions up to 2003, it is an excellent native sparklines tool. The rest of us can stop now.

    Fernando has come up with dozens of innovative display implementations for Excel:

    http://www.prodomosua.eu/ppage02.html

    (also posted in this thread: http://www.dailydoseofexcel.com/archives/2006/02/05/in-cell-charting/)

Leave a Reply

Your email address will not be published. Required fields are marked *