请求编写VBA代码：将Excel图表复制至仪表盘并与模板形状对齐

问题说明 #

作为VBA新手，已通过透视表准备好Excel仪表盘数据，需要实现：

• 将"Excess_DT"、"DT Allowed Vs DT Punched"、"Excess DT %"、"Analyst Count"工作表中的图表复制到"Final Dashboard"模板工作表
• 复制的图表需与模板内指定形状精准对齐
• 代码需具备动态性，多次运行宏时不会因图表编号/索引问题出错
• 现有代码仅能完成基础复制粘贴，无法满足需求

原问题代码 #

Dim chrt1 As ChartObject
Dim chrt2 As ChartObject
Dim chrt3 As ChartObject
Dim chrt4 As ChartObject

Set chrt1 = Sheets("Excess_DT").ChartObjects(1)
Set chrt2 = Sheets("DT Allowed Vs DT Punched").ChartObjects(1)
Set chrt3 = Sheets("Excess DT %").ChartObjects(1)
Set chrt4 = Sheets("Analyst Count").ChartObjects(1)

ActiveWorkbook.ShowPivotTableFieldList = False
chrt1.Select
chrt1.Copy
Sheets("Final Dashboard").Select
ActiveSheet.Paste
Set targetchart1 = Sheets("Final Dashboard").ActiveChart
targetchart1.IncrementLeft 397.8571653543

解决方案代码 #

以下代码解决了动态性问题，通过模板形状定位实现精准对齐，且避免依赖索引/编号：

Sub UpdateDashboardCharts()
    Dim wsDashboard As Worksheet
    Dim wsSource As Worksheet
    Dim sourceChart As ChartObject
    Dim targetShape As Shape
    Dim chartMapping As Variant
    Dim i As Integer
    Dim pastedChart As ChartObject
    
    ' 定义图表来源与目标形状的映射（工作表名 -> 模板中目标形状名称）
    ' 请根据你的模板实际形状名称修改这里的映射关系
    chartMapping = Array( _
        Array("Excess_DT", "ChartTarget_ExcessDT"), _
        Array("DT Allowed Vs DT Punched", "ChartTarget_AllowedPunched"), _
        Array("Excess DT %", "ChartTarget_ExcessPercent"), _
        Array("Analyst Count", "ChartTarget_AnalystCount") _
    )
    
    ' 初始化仪表盘工作表
    Set wsDashboard = ThisWorkbook.Sheets("Final Dashboard")
    ActiveWorkbook.ShowPivotTableFieldList = False
    
    ' 遍历所有需要复制的图表
    For i = LBound(chartMapping) To UBound(chartMapping)
        ' 获取来源工作表
        Set wsSource = ThisWorkbook.Sheets(chartMapping(i)(0))
        ' 获取来源工作表中的第一个图表（如果有多个，建议用ChartObjects("图表名称")指定）
        Set sourceChart = wsSource.ChartObjects(1)
        
        ' 获取模板中的目标形状
        On Error Resume Next
        Set targetShape = wsDashboard.Shapes(chartMapping(i)(1))
        On Error GoTo 0
        
        ' 如果目标形状存在，执行复制对齐操作
        If Not targetShape Is Nothing Then
            ' 先删除仪表盘上已有的同位置旧图表（避免重复堆积）
            Dim existingChart As ChartObject
            For Each existingChart In wsDashboard.ChartObjects
                ' 判断旧图表是否在目标形状区域内，或者直接按名称删除（如果之前命名了）
                If existingChart.Top >= targetShape.Top - 5 And existingChart.Left >= targetShape.Left - 5 Then
                    existingChart.Delete
                    Exit For
                End If
            Next
            
            ' 复制并粘贴图表
            sourceChart.Copy
            wsDashboard.Paste Destination:=wsDashboard.Range(targetShape.TopLeftCell.Address)
            
            ' 获取粘贴后的图表对象
            Set pastedChart = wsDashboard.ChartObjects(wsDashboard.ChartObjects.Count)
            
            ' 对齐到目标形状的位置和大小
            With pastedChart
                .Top = targetShape.Top
                .Left = targetShape.Left
                .Width = targetShape.Width
                .Height = targetShape.Height
                ' 可选：给图表命名，方便后续识别
                .Name = "Chart_" & chartMapping(i)(0)
            End With
        End If
    Next i
    
    ' 释放对象
    Set wsDashboard = Nothing
    Set wsSource = Nothing
    Set sourceChart = Nothing
    Set targetShape = Nothing
    Set pastedChart = Nothing
End Sub

关键说明 #

1. 动态映射配置：通过chartMapping数组定义来源工作表和模板目标形状的对应关系，无需修改核心代码，只需调整映射即可适配不同图表
2. 精准对齐：直接复用模板形状的Top/Left/Width/Height属性，实现图表与模板位置完全匹配，替代手动计算偏移量
3. 避免重复图表：每次运行先删除目标位置的旧图表，多次运行宏不会出现图表堆积
4. 稳定性优化：全程不使用Select/Activate，直接操作对象，减少运行错误
5. 容错处理：添加目标形状存在性判断，避免因形状名称错误导致代码崩溃

使用前准备 #

• 在"Final Dashboard"模板中，给每个图表的目标位置形状命名（右键形状→编辑形状→形状名称），并对应修改chartMapping中的形状名称
• 如果来源工作表有多个图表，将wsSource.ChartObjects(1)改为wsSource.ChartObjects("你的图表名称")，避免依赖索引

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