VBA 条形图颜色更改 - 引用相邻单元格？

Question

我正在尝试创建一个宏，如果条形链接到的引用数据点是“实际”或“共识”，则更新给定工作表图表中所有条形的边框。此信息在同一行中给出，即图表中引用的值左侧的几个单元格。

我一直在努力完成这项工作，因为它涉及到我对宏的一定程度的熟悉程度，但我还没有，但我的教授正在寻找我来完成它。到目前为止，我的大部分工作都围绕着更简单的单元格格式宏。

我尝试记录我想做的事情并插入 If 语句以使其工作，但这最终没有产生结果。

Sub ColorBarsBasedOnColumnK()

    Dim ws As Worksheet
    Dim chrtObj As ChartObject
    Dim ser As Series
    Dim i As Integer
    Dim j As Integer
    Dim lastRow As Long
    Dim cellValue As String

    Set ws = ActiveSheet   

    For Each chrtObj In ws.ChartObjects

        Set ser = chrtObj.Chart.SeriesCollection(1)
        For i = 1 To ser.Points.Count

            lastRow = ws.Cells(ws.Rows.Count, ser.XValues(1).Column).End(xlUp).Row           

            If i <= lastRow Then

                cellValue = ws.Cells(i + 1, 11).Value
                If cellValue = "E" Then
                    ser.Points(i).Format.Fill.ForeColor.RGB = RGB(255, 0, 0) ' Red color, adjust as needed
                Else
                    ser.Points(i).Format.Fill.ForeColor.RGB = RGB(0, 0, 255) ' Blue color, adjust as needed
                End If
            End If
        Next i
    Next chrtObj
End Sub

Answer 1

您可以通过查看系列的

Formula

属性来获取系列的基础源范围。

例如：

Sub ColorBarsBasedOnColumnK()

    Dim ws As Worksheet, chrtObj As ChartObject
    Dim ser As series, i As Integer
    Dim rngVals As Range, typ, clr As Long

    Set ws = ActiveSheet

    For Each chrtObj In ws.ChartObjects
        Set ser = chrtObj.Chart.SeriesCollection(1)
        Set rngVals = GetChartRange(ser, "values") 'get the values range for this series
        For i = 1 To ser.Points.Count
            typ = rngVals.Cells(i).EntireRow.Columns("K").Value 'get the classification: for example from ColK
            clr = IIf(typ = "E", vbRed, vbBlue)                 'determine the color
            ser.Points(i).Format.Line.ForeColor.RGB = clr       'apply the color
        Next i
    Next chrtObj
End Sub

'adapted from  http://www.vbaexpress.com/forum/showthread.php?30968-Finding-data-range-reference-for-a-series-in-chart-using-vba
'ValOrX: String, either "values" or "xvalues"
Function GetChartRange(ser As series, ValOrX As String) As Range
    Dim arr
    arr = Split(ser.Formula, Application.International(xlListSeparator))
    If UBound(arr) <> 3 Then Exit Function 'check contiguous ranges involved
    
    Select Case UCase(ValOrX) 'XValues or Values?
        Case "XVALUES": Set GetChartRange = Range(arr(1))
        Case "VALUES": Set GetChartRange = Range(arr(2))
    End Select
End Function