基于Excel动态命名表数据，用VBA批量创建散点图表

我有一个可动态更新的Excel命名表，表结构如下：

我的目标是用VBA为表中每个Item创建无标记散点折线图，且X轴值为倒序。目前已写的代码能提取唯一Item名称并创建对应数量的图表，但无法获取每个Item对应的X、Y轴数据填充到图表里，求解决方案。现有代码如下：

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

要获取每个Item对应的X、Y数据并实现X轴倒序，可按以下方式修改代码：

Sub MultiChart()
    Dim pDict As Object
    Dim tbl As ListObject
    Dim currentItem As String
    Dim cht As Chart
    Dim xTitle As String, yTitle As String
    Dim filteredX As Variant, filteredY As Variant
    Dim i As Integer
    
    ' 初始化字典和表格对象
    Set pDict = CreateObject("Scripting.Dictionary")
    Set tbl = Worksheets("Sheet1").ListObjects("Table1")
    
    ' 提取唯一Item名称
    For Each cell In tbl.ListColumns("Item Name").DataBodyRange
        If cell.Value <> "" Then pDict(cell.Value) = 1
    Next cell
    
    ' 获取轴标题文本
    xTitle = tbl.HeaderRowRange(2).Value
    yTitle = tbl.HeaderRowRange(4).Value
    
    ' 遍历每个Item创建图表
    For i = 0 To pDict.Count - 1
        currentItem = pDict.Keys()(i)
        
        ' 筛选当前Item的数据行
        tbl.Range.AutoFilter Field:=1, Criteria1:=currentItem
        
        ' 收集筛选后的X、Y值（自动排除空行）
        filteredX = tbl.ListColumns("X Axis Value").DataBodyRange.SpecialCells(xlCellTypeVisible).Value
        filteredY = tbl.ListColumns("Y Axis Value").DataBodyRange.SpecialCells(xlCellTypeVisible).Value
        
        ' 创建新图表
        Set cht = Charts.Add
        With cht
            .ChartType = xlXYScatterLinesNoMarkers
            .HasTitle = True
            .ChartTitle.Text = currentItem
            .SeriesCollection.NewSeries
            .SeriesCollection(1).Name = currentItem
            ' 赋值X、Y轴数据
            .SeriesCollection(1).XValues = filteredX
            .SeriesCollection(1).Values = filteredY
            .HasLegend = False
            ' 设置轴标题
            .Axes(xlCategory, xlPrimary).HasTitle = True
            .Axes(xlCategory, xlPrimary).AxisTitle.Text = xTitle
            .Axes(xlValue, xlPrimary).HasTitle = True
            .Axes(xlValue, xlPrimary).AxisTitle.Text = yTitle
            ' 设置X轴倒序显示
            .Axes(xlCategory).ReversePlotOrder = True
            
            ' 复制图表到指定位置
            .ChartArea.Copy
            Worksheets("Sheet1").Range("A" & ((i + 1) * 38)).PasteSpecial xlPasteValues
            ' 删除临时创建的独立图表
            .Delete
        End With
    Next i
    
    ' 取消表格的筛选状态
    tbl.Range.AutoFilter
End Sub

关键修改说明： #

• 通过筛选获取对应数据：利用Excel表格的AutoFilter功能筛选当前Item，再用SpecialCells(xlCellTypeVisible)直接提取可见行的X、Y值，避免手动循环遍历，效率更高。
• 一键设置X轴倒序：添加.Axes(xlCategory).ReversePlotOrder = True，直接实现X轴从大到小显示，无需手动反转数据数组。
• 优化图表逻辑：每个Item创建独立图表，完成后删除临时图表避免残留；直接用Item名称作为图表标题和系列名称，无需临时写入单元格。
• 恢复表格状态：最后取消筛选，避免影响后续对表格的操作。

内容的提问来源于stack exchange，提问作者user23316007