excel - 从表中的动态列创建多个图表

Question

我想创建一个宏，它遍历表中的一系列数据，并能够从中自动创建多个格式化的图表。

这是我正在使用的（下）：

Sub MakeXYGraph()
    'https://stackoverflow.com/questions/62285791/dynamically-select-cells-and-input-in-chart
    Dim ws As Worksheet
    Set ws = Sheet1 'This is the codename of the sheet where the data is
    'For the test, deleting all the previous charts
    Dim vChartObject As ChartObject
    For Each vChartObject In ws.ChartObjects
        vChartObject.Delete
    Next vChartObject
    'rngData is the range where the data are. It is assumed that nothing else is on the sheet than what you displ
    Dim rngData As Range
    Set rngData = ws.UsedRange.Offset(1).Resize(ws.UsedRange.Rows.Count - 1)
    ' Get the number of series
    Dim iMaxSeries As Integer
    iMaxSeries = Application.WorksheetFunction.Max(rngData.Columns(1))
    ' Is the actual Series, but in the sheet it called Point
    Dim iPoint As Integer
    'Used for setting the ranges for the series data
    Dim lFirstRow As Long, lLastRow As Long, lFirstColumn As Long, lLastColumn As Long
    lFirstColumn = rngData(1).Column
    lLastColumn = rngData.Columns(rngData.Columns.Count).Column
    'Creating the Chart
    Dim cht As ChartObject
    Set cht = ws.ChartObjects.Add(Left:=250, Width:=500, Top:=50, Height:=300)
    With cht.Chart
        .ChartType = xlXYScatterLines
        'X axis name
        .Axes(xlCategory, xlPrimary).HasTitle = True
        .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Vertical Displacement"
        'Y-axis name
        .Axes(xlValue, xlPrimary).HasTitle = True
        .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Vertical Coordinate"
        ' deleting the unwanted series (Excel tries to find out the data, but no need for it.)
        Do Until .SeriesCollection.Count = 0
            .SeriesCollection(1).Delete
        Loop
    End With
    For iPoint = 1 To iMaxSeries
        'Search for the first occurence of the point
        lFirstRow = rngData.Columns(1).Offset(-1).Find(what:=iPoint).Row
        'Search for the first occurence of the second point -1 is the last of this point
        If iPoint = iMaxSeries Then
            lLastRow = rngData.Rows(rngData.Rows.Count).Row - 1
        Else
            lLastRow = rngData.Columns(1).Find(what:=iPoint + 1).Row - 1
        End If
        'Add the series
        With cht.Chart.SeriesCollection.NewSeries
            .XValues = ws.Range(Cells(lFirstRow, lFirstColumn + 1), Cells(lLastRow, lLastColumn - 1))
            .Values = ws.Range(Cells(lFirstRow, lFirstColumn + 2), Cells(lLastRow, lLastColumn))
            .Name = "Point " & CStr(iPoint)
        End With
    Next iPoint
End Sub

其中绘制了该表中的垂直坐标与垂直位移列：

要创建此图表：

但是，正如您从带有表格的图像中看到的那样，我有多个列，我想为几列制作图表，所有列的格式都与上面的垂直坐标与垂直位移图表相同，而不会干扰之前创建的图表。例如，我想创建的第二个图表是垂直坐标与垂直应力。此工作表上还有其他数据，因此不能假设工作表的其余部分为空白。

一个问题是，如您所见，有四个不同的点号（1、2、3、4），每个点号被迭代 9 次。但是，这些数字可能会发生变化（例如，可能有 8 个点数，每个点数有 3 次迭代，因此数据是动态的，不应只考虑 9 次迭代的 4 个点数）。并且表格数据将始终从单元格“C8”开始。当前的代码处理这个问题。

当前代码不满足这一点的原因是因为它假设表所在的工作表上没有其他数据（但有）。我希望能够在不影响其他图表的情况下添加更多列并创建更多图表（所有图表都针对垂直坐标列绘制）。如果有任何方法可以修改代码，那么我可以在同一个工作表上为多组数据创建图表，那将不胜感激！我不确定解决这个问题的最佳方法是什么。谢谢你。

https://drive.google.com/file/d/1cuW2eWYwrkNeJ-TmatiC4-PFodflNbSN/view?usp=sharing

标签： excelvbaexcel-charts

Answer 1

这是一种方法：

Sub MakeXYGraph()

    Const PLOT_HEIGHT As Long = 200
    Const PLOT_WIDTH As Long = 300
    Dim ws As Worksheet
    Dim cht As ChartObject
    Dim rngData As Range, rngHeaders As Range
    Dim col As Long, posTop As Long, posLeft As Long
    Dim ptRanges As Object, pt, dataRows As Range, i As Long

    Set ws = Sheet1 'This is the codename of the sheet where the data is

    For i = ws.ChartObjects.Count To 1 Step -1
        ws.ChartObjects(i).Delete
    Next i

    Set rngData = ws.Range("C7").CurrentRegion
    Set rngHeaders = rngData.Rows(1) 'the header row
    Set rngData = rngData.Offset(1, 0).Resize(rngData.Rows.Count - 1) 'just the data

    Set ptRanges = PointRanges(rngData.Columns(1))

    posTop = ws.Range("M2").Top
    posLeft = ws.Range("M2").Left

    For col = 3 To rngData.Columns.Count

        'add the chart
        Set cht = NewChart(ws, posLeft, PLOT_WIDTH, posTop, PLOT_HEIGHT, rngHeaders.Cells(col).Value)

        'loop over the keys of the dictionary containing the point numbers and corresponding ranges
        For Each pt In ptRanges
            Set dataRows = ptRanges(pt).EntireRow
            With cht.Chart.SeriesCollection.NewSeries
                .XValues = dataRows.Columns(rngData.Columns(col).Column)
                .Values = dataRows.Columns(rngData.Columns(2).Column)
                .Name = "Point " & pt
            End With
        Next pt

        posTop = posTop + PLOT_HEIGHT
    Next col
End Sub

'Scan the "point No" column and collect unique values and
'  corresponding ranges in a Scripting Dictionary object
'  assumes data is sorted by point no
Function PointRanges(pointsRange As Range) As Object
    Dim dict As Object, c As Range, p, rng As Range
    Set dict = CreateObject("scripting.dictionary")
    For Each c In pointsRange.Cells
        p = c.Value
        If Not dict.exists(p) Then
            dict.Add p, c 'add the start cell
        Else
            Set dict(p) = dict(p).Resize(dict(p).Count + 1) 'resize to add this cell
        End If
    Next c
    Set PointRanges = dict
End Function

'add a chart and do some initial configuration
Function NewChart(ws As Worksheet, L, W, T, H, yAxisName As String)
    Dim cht As ChartObject
    Set cht = ws.ChartObjects.Add(Left:=L, Width:=W, Top:=T, Height:=H)
    With cht.Chart
        .ChartType = xlXYScatterLines
        .Axes(xlCategory, xlPrimary).HasTitle = True 'X axis name
        .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = yAxisName
        .Axes(xlValue, xlPrimary).HasTitle = True 'Y-axis name
        .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Vertical Coordinate"
        .Axes(xlValue, xlPrimary).ReversePlotOrder = True
        Do While .SeriesCollection.Count > 0
            .SeriesCollection(1).Delete
        Loop
    End With
    Set NewChart = cht
End Function