In Cell Charting

In Cell Charting

February 05, 2006, 5:44 pm by Rob van Gelder

I discovered a while ago that you can create a Shape from a user-defined function.
This opens the possibility for having custom made graphics dependent on other cells. Meaning, when the data changes, your graphic changes too.

Some possible graphics include line charts, gantt charts, Excel12 style traffic lights.

As an example, I've put together a very basic Sparkline (in-cell line chart) graphic. If you want to know more about Sparklines, start at ewbi.develops

I have a userdefined function named LineChart. It will take a row of values and use them to create a simple linechart within the cell containing the formula.

The formula in cell K1 is =LineChart(A1:J1, 203)
A1:J1 are the data values
203 repesents the colour value for RGB(203, 0, 0)

Finally, the code behind the user-defined function:

Function LineChart(Points As Range, Color As Long) As String
    Const cMargin = 2
    Dim rng As Range, arr() As Variant, i As Long, j As Long, k As Long
    Dim dblMin As Double, dblMax As Double, shp As Shape
 
    Set rng = Application.Caller
 
    ShapeDelete rng
 
    For i = 1 To Points.Count
        If j = 0 Then
            j = i
        ElseIf Points(, j)> Points(, i) Then
            j = i
        End If
        If k = 0 Then
            k = i
        ElseIf Points(, k) <Points(, i) Then
            k = i
        End If
    Next
    dblMin = Points(, j)
    dblMax = Points(, k)
 
    With rng.Worksheet.Shapes
        For i = 0 To Points.Count - 2
            Set shp = .AddLine( _
                cMargin + rng.Left + (i * (rng.Width - (cMargin * 2)) / (Points.Count - 1)), _
                cMargin + rng.Top + (dblMax - Points(, i + 1)) * (rng.Height - (cMargin * 2)) / (dblMax - dblMin), _
                cMargin + rng.Left + ((i + 1) * (rng.Width - (cMargin * 2)) / (Points.Count - 1)), _
                cMargin + rng.Top + (dblMax - Points(, i + 2)) * (rng.Height - (cMargin * 2)) / (dblMax - dblMin))
 
            On Error Resume Next
            j = 0: j = UBound(arr) + 1
            On Error GoTo 0
            ReDim Preserve arr(j)
            arr(j) = shp.Name
        Next
 
        With rng.Worksheet.Shapes.Range(arr)
            .Group
 
            If Color> 0 Then .Line.ForeColor.RGB = Color Else .Line.ForeColor.SchemeColor = -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

ShapeDelete is an alteration of the ShapeDelete code available on my website
Note that Application.Caller is used to determine which cell is running the formula. That is also used for determining the boundaries of the cell.
One "gotcha" about UDF charts is that you cannot create any shape that writes Text. That can make drawing Legend tables or Value indicators difficult. That said, it's great for drawing graphics.