Add high/low points to a line chart

[limetoad]

I am trying to figure out how to add high/low points to a line graph, similar to what sparklines have. The file I am using now doesn't allow me to add new columns of data, so I'm trying to figure something out that just updates dynamically using the data I already have in place.

This page has the thing I want to do, but it requires additional columns to be added to work, which I don't want:

Excelmate, Excel - Show High/Low Points on a Line Chart

Any thoughts on how this can be done? I'd appreciate any help.

 

[pbornemeier]

This is working with series one of an embedded line chart. A different series or different chart type will required some modification.

Option Explicit

Sub SetArrowsOnEmbeddedChartHiLowPoints()

    'This code will examine Series 1 and place the up and down arrows at
    '  the highest and lowest points on the graph (if more than one then the leftmost one)

    Dim lX As Long
    Dim sngXHi As Single, sngXLo As Single
    Dim sngYHi As Single, sngYLo As Single
    Dim sngHiValue As Single, sngLoValue As Single
    Dim lHiPos As Long
    Dim lLoPos As Long
    Dim sngXPos As Single, sngYPos As Single
    Dim sngShapeYOffset As Single, sngShapeXOffset As Single
    Dim shp As Excel.Shape
    Dim sFormula As Variant
    Dim sValues As Variant
    
    sngYHi = 0
    sngYLo = 100000
    
    sFormula = Split(ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1).Formula, ",")
    sValues = Range(sFormula(2))
    
    For lX = 1 To ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1).Points.Count
        ActiveSheet.ChartObjects(1).Select
        sngXPos = ExecuteExcel4Macro("get.chart.item(1,1, ""S1P" & lX & """)")
        sngYPos = ExecuteExcel4Macro("get.chart.item(2,1, ""S1P" & lX & """)")
        
        If sngYPos > sngYHi Then
            sngXHi = sngXPos
            sngYHi = sngYPos
            sngHiValue = sValues(lX, 1)
        End If
        If sngYLo > sngYPos Then
            sngXLo = sngXPos
            sngYLo = sngYPos
            sngLoValue = sValues(lX, 1)
        End If
    Next
    
    With ActiveSheet.ChartObjects(1).Chart
        For lX = .Shapes.Count To 1 Step -1
            If Left(.Shapes(lX).Name, 5) = "xyzzy" Then .Shapes(lX).Delete
        Next
    End With
    
    Const lRedLine As Long = 3553420
    Const lRedFill As Long = 5066944
    Const lGrnLine As Long = 4163953
    Const lGrnFill As Long = 5880731
    
    Set shp = ActiveSheet.Shapes.AddShape(msoShapeUpArrow, 20, 20, 20, 20) 'X,Y,W,H
    shp.Fill.ForeColor.RGB = lGrnFill 'RGB(255, 0, 0)
    shp.Line.ForeColor.RGB = lGrnLine 'RGB(255, 0, 0)
    shp.Name = "xyzzy_UpArrow"
    
    Set shp = ActiveSheet.Shapes.AddShape(msoShapeDownArrow, 20, 40, 20, 20) 'X,Y,W,H
    shp.Fill.ForeColor.RGB = lRedFill 'RGB(255, 0, 0)
    shp.Line.ForeColor.RGB = lRedLine 'RGB(255, 0, 0)
    shp.Name = "xyzzy_DnArrow"
    
    sngShapeYOffset = ActiveSheet.Shapes("xyzzy_UpArrow").Width / 2
    sngShapeXOffset = ActiveSheet.Shapes("xyzzy_UpArrow").Height / 2
    
    With ActiveSheet.ChartObjects(1).Chart
    
        ActiveSheet.Shapes("xyzzy_UpArrow").Copy
        .Paste
        With .Shapes(.Shapes.Count)
            .Left = sngXHi - sngShapeXOffset
            .Top = ActiveChart.ChartArea.Height - sngYHi - sngShapeYOffset
            .Name = "xyzzy_Up"
        End With
        
        Set shp = .Shapes.AddShape(msoShapeRectangle, 20, 20, 20, 20) 'X,Y,W,H
        With shp
            .Left = sngXHi + sngShapeXOffset
            .Top = ActiveChart.ChartArea.Height - sngYHi - sngShapeYOffset
            .Name = "xyzzy_UpText"
            With .TextFrame.Characters
                .Text = sngHiValue
                .Font.Color = 1
            End With
            .Fill.Visible = False
            .Line.Visible = False
            .TextFrame.AutoSize = True
        End With
        
        ActiveSheet.Shapes("xyzzy_DnArrow").Copy
        .Paste
        With .Shapes(.Shapes.Count)
            .Left = sngXLo - sngShapeXOffset
            .Top = ActiveChart.ChartArea.Height - sngYLo - sngShapeYOffset
            .Name = "xyzzy_Dn"
        End With
    
        Set shp = .Shapes.AddShape(msoShapeRectangle, 20, 20, 20, 20) 'X,Y,W,H
        With shp
            .Left = sngXLo + sngShapeXOffset
            .Top = ActiveChart.ChartArea.Height - sngYLo - sngShapeYOffset
            .Name = "xyzzy_UDnText"
            With .TextFrame.Characters
                .Text = sngLoValue
                .Font.Color = 1
            End With
            
            .Fill.Visible = False
            .Line.Visible = False
            .TextFrame.AutoSize = True
        End With
        
    End With
    
    ActiveSheet.Shapes("xyzzy_UpArrow").Delete
    ActiveSheet.Shapes("xyzzy_DnArrow").Delete
    ActiveSheet.Range("A1").Select
    
    Set shp = Nothing

End Sub

 

[limetoad]

Thanks for the reply, pbornemeier. I was able to figure out some code that is a little simpler and works for what I need. Here's the code if anyone is interested:

Sub HighLowPoints()
Dim ws As Worksheet
Dim p As Point
Dim vMin As Variant
Dim vMax As Variant
Dim pMin As Variant
Dim pMax As Variant
Dim sh As Shape
Dim v As Variant
Dim i As Integer


'Goes through all my sheets in the current workbook
For Each ws In ActiveWorkbook.Worksheets
    'If it finds a sheet that I want it to work in...
    Select Case ws.Name
    Case "EUR", "GC", "LAM", "NAM", "NEA", "SEA"
        'Then it goes through the shapes until it finds one with a name that I've decided needs to be worked on...
        For Each sh In ActiveSheet.Shapes
            If sh.Name = "DistrTrend" Or sh.Name = "PCTrend" Then
                'Then it takes all the SeriesCollection values and puts them into a variable, and finds the max/min values in that array.
                v = sh.Chart.SeriesCollection(1).Values
                vMin = Application.WorksheetFunction.Min(v)
                vMax = Application.WorksheetFunction.Max(v)
                pMin = Application.WorksheetFunction.Match(vMin, v, 0)
                pMax = Application.WorksheetFunction.Match(vMax, v, 0)
                'Then goes through all the values in the line chart, and if a point is equal to the already determined min/max value it adds a point there, the same size as a sparkline point.
                For Each p In sh.Chart.SeriesCollection(1).Points
                    i = Right(p.Name, Len(p.Name) - 3)
                    Select Case i
                    Case pMin, pMax
                        p.MarkerBackgroundColorIndex = 1
                        p.MarkerForegroundColorIndex = 1
                        p.MarkerStyle = 2
                        p.MarkerSize = 2
                    End Select
                Next p
            End If
        Next sh
    End Select
Next ws
End Sub