VBA：修改图表数据范围

Question

我的“图表数据范围”为='sheet1'!$A$1:$Z$10。我想制作一个VBA宏（或者如果有人知道我可以使用的公式，但我无法想出一个），每次运行时，chart1的范围的结束列都会增加1宏。基本上是这样的：

chart1.endCol = chart1.endCol + 1

使用ActiveChart的语法是什么？还是有更好的方法？

Answer 1

Offset function动态范围使其成为可能。

示例数据

步骤

• 定义动态命名范围 =OFFSET(Sheet1!$A$2,,,1,COUNTA(Sheet1!$A$2:$Z$2))然后给它一个 名称mobileRange
• 右键单击图表
• 点击选择数据

此屏幕将会出现

点击图例条目下的Edit。（已选择手机）

• 将系列值更改为指向mobileRange命名范围。
• 现在，如果将来月的数据添加到移动销售中，它将自动反映在图表中。

Answer 2

假设您要扩展范围（通过添加一个额外的列）为图中的每个系列添加一个观察（而不是添加新系列），您可以使用此代码：

Sub ChangeChartRange()
    Dim i As Integer, r As Integer, n As Integer, p1 As Integer, p2 As Integer, p3 As Integer
    Dim rng As Range
    Dim ax As Range

    'Cycles through each series
    For n = 1 To ActiveChart.SeriesCollection.Count Step 1
        r = 0

        'Finds the current range of the series and the axis
        For i = 1 To Len(ActiveChart.SeriesCollection(n).Formula) Step 1
            If Mid(ActiveChart.SeriesCollection(n).Formula, i, 1) = "," Then
                r = r + 1
                If r = 1 Then p1 = i + 1
                If r = 2 Then p2 = i
                If r = 3 Then p3 = i
            End If
        Next i


        'Defines new range
        Set rng = Range(Mid(ActiveChart.SeriesCollection(n).Formula, p2 + 1, p3 - p2 - 1))
        Set rng = Range(rng, rng.Offset(0, 1))

        'Sets new range for each series
        ActiveChart.SeriesCollection(n).Values = rng

        'Updates axis
        Set ax = Range(Mid(ActiveChart.SeriesCollection(n).Formula, p1, p2 - p1))
        Set ax = Range(ax, ax.Offset(0, 1))
        ActiveChart.SeriesCollection(n).XValues = ax

    Next n
End Sub

Answer 3

假设您只使用Chart Selected运行宏，我的想法是改变每个Series的公式中的范围。您可以将更改应用于工作表中的所有图表。

更新：已更改代码以适应带屏幕截图的多个系列

Sub ChartRangeAdd()
    On Error Resume Next
    Dim oCht As Chart, aFormulaOld As Variant, aFormulaNew As Variant
    Dim i As Long, s As Long
    Dim oRng As Range, sTmp As String, sBase As String

    Set oCht = ActiveSheet.ChartObjects(1).Chart
    oCht.Select
    For s = 1 To oCht.SeriesCollection.count
        sTmp = oCht.SeriesCollection(s).Formula
        sBase = Split(sTmp, "(")(0) & "(<FORMULA>)" ' "=SERIES(" & "<FORMULA>)"
        sTmp = Split(sTmp, "(")(1) ' "..., ..., ...)"
        aFormulaOld = Split(Left(sTmp, Len(sTmp) - 1), ",") ' "..., ..., ..."
        aFormulaNew = Array()
        ReDim aFormulaNew(UBound(aFormulaOld))
        ' Process all series in the formula
        For i = 0 To UBound(aFormulaOld)
            Set oRng = Range(aFormulaOld(i))
            ' Attempt to put the value into Range, keep the same if it's not valid Range
            If Err.Number = 0 Then
                Set oRng = oRng.Worksheet.Range(oRng, oRng.Offset(0, 1))
                aFormulaNew(i) = oRng.Worksheet.Name & "!" & oRng.Address
            Else
                aFormulaNew(i) = aFormulaOld(i)
                Err.Clear
            End If
        Next i
        sTmp = Replace(sBase, "<FORMULA>", Join(aFormulaNew, ","))
        Debug.Print "Series(" & s & ") from """ & oCht.SeriesCollection(s).Formula & """ to """ & sTmp & """"
        oCht.SeriesCollection(s).Formula = sTmp
        sTmp = ""
    Next s
    Set oCht = Nothing
End Sub

样本数据 - 初始

首次运行后：

第二次运行：

第三次运行：

Answer 4

PatricK的答案在进行一些细微调整后效果很好：

新系列字符串的格式需要在第22行aFormulaNew(i) = "'" & oRng.Worksheet.Name & "'" & "!" & oRng.Address的工作表名称周围包含撇号。另外，如果要更改行而不是列，请将第21行的偏移量更改为Set oRng = oRng.Worksheet.Range(oRng, oRng.Offset(1, 0))或根据需要更改。也可以为范围中的第一个元素添加oRng.Offset(1, 0)，以调整系列的开始位置：Set oRng = oRng.Worksheet.Range(oRng.Offset(1, 0), oRng.Offset(1, 0))

Sub ChartRangeAdd()
    On Error Resume Next
    Dim oCht As Chart, aFormulaOld As Variant, aFormulaNew As Variant
    Dim i As Long, s As Long
    Dim oRng As Range, sTmp As String, sBase As String

    Set oCht = ActiveSheet.ChartObjects(1).Chart
    oCht.Select
    For s = 1 To oCht.SeriesCollection.count
        sTmp = oCht.SeriesCollection(s).Formula
        sBase = Split(sTmp, "(")(0) & "(<FORMULA>)" ' "=SERIES(" & "<FORMULA>)"
        sTmp = Split(sTmp, "(")(1) ' "..., ..., ...)"
        aFormulaOld = Split(Left(sTmp, Len(sTmp) - 1), ",") ' "..., ..., ..."
        aFormulaNew = Array()
        ReDim aFormulaNew(UBound(aFormulaOld))
        ' Process all series in the formula
        For i = 0 To UBound(aFormulaOld)
            Set oRng = Range(aFormulaOld(i))
            ' Attempt to put the value into Range, keep the same if it's not valid Range
            If Err.Number = 0 Then
                Set oRng = oRng.Worksheet.Range(oRng, oRng.Offset(0, 1))
                aFormulaNew(i) = "'" & oRng.Worksheet.Name & "'" & "!" & oRng.Address
            Else
                aFormulaNew(i) = aFormulaOld(i)
                Err.Clear
            End If
        Next i
        sTmp = Replace(sBase, "<FORMULA>", Join(aFormulaNew, ","))
        Debug.Print "Series(" & s & ") from """ & oCht.SeriesCollection(s).Formula & """ to """ & sTmp & """"
        oCht.SeriesCollection(s).Formula = sTmp
        sTmp = ""
    Next s
    Set oCht = Nothing
End Sub

Answer 5

PatricK 和西尔贝德维尔让我很好地开始了这个工作。现在，我正在尝试将它合并到一个单独的子项中，我可以参考它来处理多个图表。不幸的是，我在引用中遗漏了一些东西，所以它没有进行更新（也没有产生错误）。

第一个子使用第二个子

If ws < numTabs - 1 Then
    chartUpdate Summary, Chart_BidsByMonth ' Name of sheet with target chart, Name of target chart
    chartUpdate Summary, Chart_SoldByMonth ' Name of sheet with target chart, Name of target chart
End If

第二次子处理图表范围更新

Sub chartUpdate(shtRef As Variant, chtRef As Variant)
    On Error Resume Next
    Dim oCht As Chart, aFormulaOld As Variant, aFormulaNew As Variant
    Dim n As Long, s As Long
    Dim oRng As Range, sTmp As String, sBase As String

        ' Update chart referenced as chtRef '
        Set oCht = Sheets(""" & shtRef & """).ChartObjects(""" & chtRef """).Chart
        oCht.Select
        For s = 1 To oCht.SeriesCollection.Count
            sTmp = oCht.SeriesCollection(s).Formula
            sBase = Split(sTmp, "(")(0) & "(<FORMULA>)" ' "=SERIES(" & "<FORMULA>)"
            sTmp = Split(sTmp, "(")(1) ' "..., ..., ...)"
            aFormulaOld = Split(Left(sTmp, Len(sTmp) - 1), ",") ' "..., ..., ..."
            aFormulaNew = Array()
            ReDim aFormulaNew(UBound(aFormulaOld))
            ' Process all series in the formula
            For n = 0 To UBound(aFormulaOld)
                Set oRng = Range(aFormulaOld(n))
                ' Attempt to put the value into Range, keep the same if it's not valid Range
                If Err.Number = 0 Then
                    Set oRng = oRng.Worksheet.Range(oRng, oRng.Offset(0, 1))
                    aFormulaNew(n) = "'" & oRng.Worksheet.Name & "'" & "!" & oRng.Address
                Else
                    aFormulaNew(n) = aFormulaOld(i)
                    Err.Clear
                End If
            Next n
            sTmp = Replace(sBase, "<FORMULA>", Join(aFormulaNew, ","))
            Debug.Print "Series(" & s & ") from """ & oCht.SeriesCollection(s).Formula & """ to """ & sTmp & """"
            oCht.SeriesCollection(s).Formula = sTmp
            sTmp = ""
        Next s
        Set oCht = Nothing
        ' End charts update '
    End Sub