Creating multiple charts in vba based on data in excel table?

Question

I have data in a dynamically updated, named table:

Item Name	X Axis Value	Other Data	Y Axis Value
Item A	4	###	1
Item A	3	###	2
Item A	2	###	4
Item A	1	###	5
Item A	0	###	5
Item B	2	###	2
Item B	1	###	3
Item B	0	###	3
Item C	3	###	1
Item C	2	###	1
Item C	1	###	2
Item C	0	###	2

My goal is to use vba to create a chart for each item in the table: scatter chart of Item A with x axis values in reverse order

Here's the code I have so far. It can pull a list of unique item names and create the correct number of charts, but I am at a loss for how I could grab the correct data for each item name and load it into the chart. Any advice would be greatly appreciated...

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

Try this out:

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