VBA 根据包含一些文本的 headers 更新图表

Question

我有一张图表可以帮助我按人绘制一系列事件。在绘制图表时，我需要一些 classes 的事件来保持一致性。

例如，简在她的职业生涯中被雇用过两次。我希望 class 的租金保持不变。但是，Excel 会将它们打断为不同的 classes，因为一个名为 01-Hire，另一个名为 02-Hire。在下面的示例中，所有雇员都应该是蓝色的。

我想要一些代码在 header 中搜索 "Hire"，然后应用一致的颜色。注意，序列之间可能有不同的header，所以代码需要足够聪明，只对包含相同文本（而不是序列号）的事物进行分组。

我能找到的最接近这样做的是在这里：

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)

我想对下面的所有 class 执行此操作，类似于图表。

期望的输出

数据table

原始代码 行标签 01 - 雇用 01 - 晋升 01 - 任期 02 - 雇用 02 - 晋升 02 - 任期 03 - 雇用 03 - 晋升 03 - 任期简 38 10 29
本 15 50 10 乔 68 56 10 7
丽莎 61 41
珍妮 24
杰里 81 16

Answer 1

如果您的系列标签总是重复 "Hire x"、"Prom x"、"Term x"，那么这样的方法会起作用：

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

如果您需要根据系列名称进行操作，则：

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

VBA 根据包含一些文本的 headers 更新图表

VBA to update chart based on headers containing some text

excel

vba

excel-charts