vba - 如何在 Excel VBA 中创建自动动态折线图

Question

我遇到工作问题。我有一份包含大量信息的数据报告，我需要创建 3 个折线图来表示一段时间内的 3 个不同值。该时间也在报告中，并且对于所有值来说都是相同的时间。我在其他论坛中找不到特定于我的解决方案。

数据报告的长度、行数各不相同。我需要做的是创建 3 个折线图，并将它们水平放置在报告末尾下方的几行处。其中两张图各有一个系列，第三张图有两个系列。

这是图表需要包含的内容:

图 1:RPM 随时间变化
图 2:压力随时间变化
图 3:随着时间的推移，步骤消耗和需求消耗

由于最近工作中的职位变动，我刚刚进入 VBA，对此我知之甚少，但我花了很多时间弄清楚如何为同一报告编写其他宏。由于我对工作簿的口头表述不清楚，因此我附上了数据报告示例的链接以供查看。

Data Report Workbook Download

这是我到目前为止所拥有的。它适用于第一个图表。现在我可以在代码中输入什么来将图表命名为“RPM”并将系列命名为“RPM”？

    Sub Test()
    Dim LastRow As Long
    Dim Rng1 As Range
    Dim ShName As String
    With ActiveSheet
        LastRow = .Range("B" & .Rows.Count).End(xlUp).Row
        Set Rng1 = .Range("B2:B" & LastRow & ", E2:E" & LastRow)
        ShName = .Name

    End With
    Charts.Add
    With ActiveChart
        .ChartType = xlLine
        .SetSourceData Source:=Rng1
        .Location Where:=xlLocationAsObject, Name:=ShName
    End With
End Sub

我已经弄清楚如何通过 VBA 将图表名称放入其中。代码现在如下所示:

Sub Test()
    Dim LastRow As Long
    Dim Rng1 As Range
    Dim ShName As String
    With ActiveSheet
        LastRow = .Range("B" & .Rows.Count).End(xlUp).Row
        Set Rng1 = .Range("B2:B" & LastRow & ", E2:E" & LastRow)
        ShName = .Name
    End With

    Charts.Add
    With ActiveChart
        .ChartType = xlLine
        .HasTitle = True
        .ChartTitle.Text = "RPM"
        .SetSourceData Source:=Rng1
        .Location Where:=xlLocationAsObject, Name:=ShName
    End With

End Sub

接下来我将处理系列标题，然后将图表置于报告数据下方。欢迎提出建议和意见。

下面更新的代码分别创建转速图表和压力图表。最后一张图表需要两个系列，我现在正在研究这个。

Sub chts()

'RPM chart-------------------------------------
    Dim LastRow As Long
    Dim Rng1 As Range
    Dim ShName As String
    With ActiveSheet
        LastRow = .Range("B" & .Rows.Count).End(xlUp).Row
        Set Rng1 = .Range("B2:B" & LastRow & ", E2:E" & LastRow)
        ShName = .Name
    End With

    Charts.Add
    With ActiveChart
        .ChartType = xlLine
        .HasTitle = True
        .ChartTitle.Text = "RPM"
        .SetSourceData Source:=Rng1
        .Location Where:=xlLocationAsObject, Name:=ShName
    End With

    With ActiveChart.SeriesCollection(1)
        .Name = "RPM"
    End With

' Pressure chart --------------------------------

    Dim LastRow2 As Long
    Dim Rng2 As Range
    Dim ShName2 As String
    With ActiveSheet
        LastRow2 = .Range("B" & .Rows.Count).End(xlUp).Row
        Set Rng2 = .Range("B2:B" & LastRow2 & ", G2:G" & LastRow2)
        ShName2 = .Name
    End With

    Charts.Add
    With ActiveChart
        .ChartType = xlLine
        .HasTitle = True
        .ChartTitle.Text = "Pressure/psi"
        .SetSourceData Source:=Rng2
        .Location Where:=xlLocationAsObject, Name:=ShName2
    End With

    With ActiveChart.SeriesCollection(1)
        .Name = "Pressure"
    End With
End Sub

大卫，我很好奇你的代码如何与我的工作表配合使用，但我不确定如何修复语法错误。

Answer 1

要操纵系列标题(每个图表中只有一个系列)，您可以简单地执行以下操作:

With ActiveChart.SeriesCollection(1)
    .Name = "RPM"
    '## You can further manipulate some series properties, like: '
    '.XValues = range_variable  '## you can assign a range of categorylabels here'
    '.Values = another_range_variable '## you can assign a range of Values here'
End With

现在，您拥有的代码是将图表添加到工作表中。但一旦创建完毕，您可能不想重新添加新图表，而只想更新现有图表。

假设每个图表中只有一个系列，您可以执行类似的操作来更新图表。

它的工作原理是迭代工作表的图表对象集合中的每个图表，然后根据图表的标题确定用于系列值的范围。

已修订以说明具有 2 个系列的第三个图表。

修订#2如果图表没有系列数据，则将系列添加到图表。

Sub UpdateCharts()
Dim cObj As ChartObject
Dim cht As Chart
Dim shtName As String
Dim chtName As String
Dim xValRange As Range
Dim LastRow As Long

With ActiveSheet
    LastRow = .Range("B" & .Rows.Count).End(xlUp).Row
    Set xValRange = .Range("B2:B" & LastRow)
    shtName = .Name & " "
End With


'## This sets values for Series 1 in each chart ##'
For Each cObj In ActiveSheet.ChartObjects
    Set cht = cObj.Chart
    chtName = shtName & cht.Name

    If cht.SeriesCollection.Count = 0 Then
    '## Add a dummy series which will be replaced in the code below ##'
        With cht.SeriesCollection.NewSeries
            .Values = "{1,2,3}"
            .XValues = xValRange
        End With

    End If

    '## Assuming only one series per chart, we just reset the Values & XValues per chart ##'
    With cht.SeriesCollection(1)
    '## Assign the category/XValues ##'
       .XValues = xValRange

    '## Here, we set the range to use for Values, based on the chart name: ##'
        Select Case Replace(chtName, shtName, vbNullString)
             Case "RPM"
                  .Values = xValRange.Offset(0, 3) '## Column E is 3 offset from the xValRange in column B
             Case "Pressure/psi"
                  .Values = xValRange.Offset(0, 5) '## Column G is 5 offset from the xValRange in column B
             Case "Third Chart"
                .Values = xValRange.Offset(0, 6)   '## Column H is 6 offset from the xValRange in column B

                '## Make sure this chart has 2 series, if not, add a dummy series ##'
                If cht.SeriesCollection.Count < 2 Then
                    With cht.SeriesCollection.NewSeries
                        .XValues = "{1,2,3}"
                    End With
                End If
                '## add the data for second series: ##'
                cht.SeriesCollection(2).XValues = xValRange
                cht.SeriesCollection(2).Values = xValRange.Offset(0, 8)  '## Column J is 8 offset from the xValRange in column B

             Case "Add as many of these Cases as you need"

        End Select

    End With

Next
End Sub

修订 #3 要允许创建工作表中尚不存在的图表，请将这些行添加到 DeleteRows_0_Step() 子例程的底部:

运行“CreateCharts”

运行“UpdateCharts”

然后，将这些子例程添加到同一代码模块中:

Private Sub CreateCharts()

Dim chts() As Variant
Dim cObj As Shape
Dim cht As Chart
Dim chtLeft As Double, chtTop As Double, chtWidth As Double, chtHeight As Double
Dim lastRow As Long
Dim c As Long
Dim ws As Worksheet

Set ws = ActiveSheet
lastRow = ws.Range("A1", Range("A2").End(xlDown)).Rows.Count

c = -1
'## Create an array of chart names in this sheet. ##'
For Each cObj In ActiveSheet.Shapes
    If cObj.HasChart Then
        ReDim Preserve chts(c)
        chts(c) = cObj.Name

        c = c + 1
    End If
Next

'## Check to see if your charts exist on the worksheet ##'
If c = -1 Then
    ReDim Preserve chts(0)
    chts(0) = ""
End If
If IsError(Application.Match("RPM", chts, False)) Then
    '## Add this chart ##'
    chtLeft = ws.Cells(lastRow, 1).Left
    chtTop = ws.Cells(lastRow, 1).Top + ws.Cells(lastRow, 1).Height
    Set cObj = ws.Shapes.AddChart(xlLine, chtLeft, chtTop, 355, 211)
        cObj.Name = "RPM"
        cObj.Chart.HasTitle = True
        Set cht = cObj.Chart
        cht.ChartTitle.Characters.Text = "RPM"
        clearChart cht
End If


If IsError(Application.Match("Pressure/psi", chts, False)) Then
    '## Add this chart ##'
    With ws.ChartObjects("RPM")
        chtLeft = .Left + .Width + 10
        chtTop = .Top
        Set cObj = ws.Shapes.AddChart(xlLine, chtLeft, chtTop, 355, 211)
        cObj.Name = "Pressure/psi"
        cObj.Chart.HasTitle = True
        Set cht = cObj.Chart
        cht.ChartTitle.Characters.Text = "Pressure/psi"
        clearChart cht
    End With
End If


If IsError(Application.Match("Third Chart", chts, False)) Then
    '## Add this chart ##'
    With ws.ChartObjects("Pressure/psi")
        chtLeft = .Left + .Width + 10
        chtTop = .Top
        Set cObj = ws.Shapes.AddChart(xlLine, chtLeft, chtTop, 355, 211)
        cObj.Name = "Third Chart"
        cObj.Chart.HasTitle = True
        Set cht = cObj.Chart
        cht.ChartTitle.Characters.Text = "Third Chart"
        clearChart cht
    End With
End If


End Sub

Private Sub clearChart(cht As Chart)
Dim srs As Series
For Each srs In cht.SeriesCollection
    If Not cht.SeriesCollection.Count = 1 Then srs.Delete
Next
End Sub