根据excel表格中的数据在vba中创建多个图表？

Question

我的数据位于动态更新的命名表中：

商品名称	X 轴值	其他数据	Y 轴值
项目A	4	###	1
项目A	3	###	2
项目A	2	###	4
项目A	1	###	5
项目A	0	###	5
B 项	2	###	2
B 项	1	###	3
B 项	0	###	3
项目C	3	###	1
项目C	2	###	1
项目C	1	###	2
项目C	0	###	2

我的目标是使用vba为表中的每个项目创建一个图表： 项目 A x 轴值倒序的散点图

这是我到目前为止的代码。它可以提取唯一项目名称的列表并创建正确数量的图表，但我不知道如何获取每个项目名称的正确数据并将其加载到图表中。任何建议将不胜感激...

Sub MultiChart()

Dim P
Dim pDict As Object
Dim pRow As Long
Dim cht As Chart
Dim cTitle As Range
Dim xTitle As Range
Dim yTitle As Range

Set pDict = CreateObject("Scripting.Dictionary")
P = Application.Transpose(Worksheets("Sheet1").ListObjects("Table1").ListColumns(1).DataBodyRange)

For pRow = 1 To UBound(P, 1)
    pDict(P(pRow)) = 1
Next
pDict.Remove ""

Set cht = Charts.Add
Set xTitle = Worksheets("Sheet1").ListObjects("Table1").HeaderRowRange(2)
Set yTitle = Worksheets("Sheet1").ListObjects("Table1").HeaderRowRange(4)

For i = 0 To pDict.Count - 1
Worksheets("Sheet1").Range("A1") = pDict.Keys()(i)
    Set cTitle = Worksheets("Sheet1").Range("A1")
    With cht
        .ChartType = xlXYScatterLinesNoMarkers
        .HasTitle = True
        .ChartTitle.Text = cTitle
        .SeriesCollection.NewSeries
        .SeriesCollection(1).Name = "=""Item Name"""
        .SeriesCollection(1).XValues = ???
        .SeriesCollection(1).Values = ???
        .HasLegend = False
        .Axes(xlCategory, xlPrimary).HasTitle = True
        .Axes(xlCategory, xlPrimary).AxisTitle.Text = xTitle
        .Axes(xlValue, xlPrimary).HasTitle = True
        .Axes(xlValue, xlPrimary).AxisTitle.Text = yTitle
        .ChartArea.Copy
    End With
    Worksheets("Sheet1").Range("A" & ((i + 1) * 38)).PasteSpecial xlPasteValues
Next i

End Sub

Answer 1

试试这个：

Sub MultiChart()

    Dim dict As Object, ws As Worksheet, i As Long
    Dim cht As Chart, lo As ListObject, r As Long, k, arr
    Dim data
    
    Set ws = Worksheets("Sheet3")
    
    ws.DrawingObjects.Delete
    
    Set lo = ws.ListObjects("Table1")
    data = lo.DataBodyRange.Value 'all table data
    
    'collect individual items, start row and number of entries
    'assumes your table is sorted on the first column....
    Set dict = CreateObject("Scripting.Dictionary")
    For r = 1 To UBound(data, 1)
        k = data(r, 1)
        If Not dict.Exists(k) Then
            dict.Add k, Array(r, 1) 'initialize start row and count
        Else
            arr = dict(k)        'can't alter an array when it's stored in a dict
            arr(1) = arr(1) + 1  'increment count
            dict(k) = arr        'return modified array to dict
        End If
    Next
    
    'set up the chart
    Set cht = Charts.Add
    With cht
        .ChartType = xlXYScatterLinesNoMarkers
        .HasTitle = True
        .HasLegend = False
        With .SeriesCollection.NewSeries
            .Name = "Item Name"
            .XValues = 1 'some dummy values...
            .Values = 1
        End With
        .Axes(xlCategory, xlPrimary).HasTitle = True
        .Axes(xlCategory, xlPrimary).AxisTitle.Text = lo.HeaderRowRange(2).Value
        .Axes(xlValue, xlPrimary).HasTitle = True
        .Axes(xlValue, xlPrimary).AxisTitle.Text = lo.HeaderRowRange(4).Value
    End With
    
    'loop over the items
    i = 1
    For Each k In dict
        cht.ChartTitle.Text = k
        arr = dict(k)
        With cht.SeriesCollection(1)
            .XValues = lo.ListColumns(2).DataBodyRange.Cells(arr(0)).Resize(arr(1))
            .Values = lo.ListColumns(4).DataBodyRange.Cells(arr(0)).Resize(arr(1))
        End With
        cht.ChartArea.Copy
        ws.Range("A" & ((i) * 38)).PasteSpecial xlPasteValues
        i = i + 1
    Next k
End Sub