Quantcast
Channel: Excel Help Forum - Excel Programming / VBA / Macros
Viewing all articles
Browse latest Browse all 50094

Help with End Sub Error in Code

$
0
0
Hi I found this code which creates sparklines (small line charts) on a website (Can't find the website again). Whenever I try and run the code I get the following error: Compile Error Expected End Sub. I've searched a few forums but haven't been able to resolve what the issue is. The code is:
Code:

Sub sparkline()
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

appreciate any help. Thx

Viewing all articles
Browse latest Browse all 50094

Trending Articles