Search code examples
vbaexcelexcel-charts

VBA to update chart based on headers containing some text


I have a chart that helps me plot out a sequence of events by person. I need some classes of events to have consistency when I chart.

For example, Jane gets hired twice in her career. I want that class of hire to be the same. However, Excel will interrupt these as different classes because one is named 01-Hire and the other 02-Hire. All hires should be blue in the example below.

I want some code to search for "Hire" in the header and then then apply a consistent color. Note, there may be different headers among sequences, so the code needs to be smart enough to only group things that contain the same text (not the sequence number).

The closest thing I could find to doing this was here: Set Color codes to the legends in vba

Private Sub FormatShapeLegend(sheet As Worksheet, legendName As String, targetColor As MsoRGBType)
    Dim shp As Shape
    Dim chrt As Chart
    Dim s As Series

    For Each shp In sheet.Shapes
        If shp.HasChart Then
            Set chrt = shp.Chart

            'Loop the dataseries to find the legend with the desired name.
            For Each s In chrt.SeriesCollection
                'If the name fits, go ahead and format the series.
                If LCase(s.Name) = LCase(legendName) Then
                    s.Format.Fill.ForeColor.RGB = targetColor
                End If
            Next
        End If
    Next
End Sub

FormatShapeLegend ActiveSheet, "ISO", RGB(0, 0, 255)

I want to do this for all classes below similar to the chart.

Desired output enter image description here

The data table enter image description here

The raw code Row Labels 01 - Hire 01 - Promotion 01 - Term 02 - Hire 02 - Promotion 02 - Term 03 - Hire 03 - Promotion 03 - Term Jane 38 10 29
Ben 15 50 10 Joe 68 56 10 7
Lisa 61 41
Jenny 24
Jerry 81 16


Solution

  • If your series labels are always repeating "Hire x","Prom x","Term x" then something like this would work:

    Dim s As Series, x As Long
    x = 0
    
    For Each s In ActiveSheet.ChartObjects(1).Chart.SeriesCollection
        x = x + 1
        s.Format.Fill.ForeColor.RGB = Array(vbBlue, vbRed, vbGreen)(x Mod 3)
    Next s
    

    If you need to do it based off the series name then:

    Dim s As Series, clr As Long, nm As String
    
    For Each s In ActiveSheet.ChartObjects(1).Chart.SeriesCollection
    
        nm = LCase(s.Name)
    
        clr = vbYellow 'default
        If nm Like "*hire*" Then
            clr = vbBlue
        ElseIf nm Like "*prom*" Then
            clr = vbGreen
        ElseIf nm Like "*term*" Then
            clr = vbRed
        End If
    
        s.Format.Fill.ForeColor.RGB = clr
    
    Next s