如何通过Excel VBA将指定图表自动粘贴到PowerPoint模板对应幻灯片

• 未定义PowerPoint常量：ppPasteMetafilePicture是PowerPoint专属常量，未添加PowerPoint对象库引用时VBA无法识别该值，直接运行会报错。该常量对应的实际值为2，后期绑定场景下可直接替换使用。
• 变量未声明：代码中strpath未提前定义，开启变量强制声明时会触发编译错误。
• 无批量匹配逻辑：仅实现了单个图表粘贴逻辑，无法满足多图表匹配指定幻灯片的需求。
• 无位置调整逻辑：默认粘贴的图表位置随机，无法适配模板排版要求。

分为两个版本，可根据使用场景选择：

版本1：前期绑定（开发用，代码提示全） #

前置操作：打开VBA编辑器（快捷键Alt+F11），点击顶部菜单「工具」→「引用」，勾选Microsoft PowerPoint XX.X 对象库（XX.X为你安装的Office版本号，16.0对应Office2016/2019/365），确认后再运行代码。

Option Explicit
Sub 批量导出图表到PPT()
    Dim PowerPointApp As PowerPoint.Application
    Dim pptPres As PowerPoint.Presentation
    Dim cht As ChartObject
    Dim strpath As String
    ' 匹配规则配置：数组第一维为图表序号，第二维为目标幻灯片序号，可自行修改
    Dim chartMap As Variant
    Dim i As Integer
    Dim pastePos As Integer ' 同页内粘贴位置标记，1=左侧，2=右侧
    
    chartMap = Array(_
        Array(1, 7), _
        Array(2, 7), _
        Array(3, 9), _
        Array(4, 9) _
    )
    
    ' 启动PPT并打开模板
    Set PowerPointApp = New PowerPoint.Application
    PowerPointApp.Visible = True ' 显示PPT窗口，可查看运行过程
    strpath = ThisWorkbook.Path & "\My_template.pptx"
    Set pptPres = PowerPointApp.Presentations.Open(strpath)
    
    ' 遍历规则批量粘贴
    For i = LBound(chartMap) To UBound(chartMap)
        Set cht = Worksheets("Graphs").ChartObjects(chartMap(i)(0))
        cht.Copy
        ' 粘贴到指定幻灯片
        pptPres.Slides(chartMap(i)(1)).Shapes.PasteSpecial DataType:=ppPasteMetafilePicture
        ' 计算同页序号调整位置
        pastePos = Application.CountIf(Application.Index(chartMap, 0, 2), chartMap(i)(1)) - _
            Application.CountIf(Application.Index(WorksheetFunction.Transpose(chartMap), 2, 0), ">" & chartMap(i)(0))
        With pptPres.Slides(chartMap(i)(1)).Shapes(pptPres.Slides(chartMap(i)(1)).Shapes.Count)
            .LockAspectRatio = msoTrue
            .Height = 250 ' 可自行调整图表高度，宽度等比缩放
            If pastePos = 1 Then
                .Left = 50 ' 左侧图表左边距
            Else
                .Left = 350 ' 右侧图表左边距，可根据幻灯片宽度调整
            End If
            .Top = 100 ' 统一上边距
        End With
    Next i
    
    ' 释放对象
    Set cht = Nothing
    Set pptPres = Nothing
    Set PowerPointApp = Nothing
    MsgBox "导出完成！"
End Sub

版本2：后期绑定（兼容性好，无需提前加引用） #

适合需要把文件发给多人使用的场景，不需要手动配置引用：

Option Explicit
Sub 批量导出图表到PPT()
    Dim PowerPointApp As Object
    Dim pptPres As Object
    Dim cht As ChartObject
    Dim strpath As String
    Dim chartMap As Variant
    Dim i As Integer
    Dim pastePos As Integer
    Const ppPasteMetafilePicture = 2 ' 手动定义常量值
    
    chartMap = Array(_
        Array(1, 7), _
        Array(2, 7), _
        Array(3, 9), _
        Array(4, 9) _
    )
    
    Set PowerPointApp = CreateObject("PowerPoint.Application")
    PowerPointApp.Visible = True
    strpath = ThisWorkbook.Path & "\My_template.pptx"
    Set pptPres = PowerPointApp.Presentations.Open(strpath)
    
    For i = LBound(chartMap) To UBound(chartMap)
        Set cht = Worksheets("Graphs").ChartObjects(chartMap(i)(0))
        cht.Copy
        pptPres.Slides(chartMap(i)(1)).Shapes.PasteSpecial DataType:=ppPasteMetafilePicture
        pastePos = Application.CountIf(Application.Index(chartMap, 0, 2), chartMap(i)(1)) - _
            Application.CountIf(Application.Index(WorksheetFunction.Transpose(chartMap), 2, 0), ">" & chartMap(i)(0))
        With pptPres.Slides(chartMap(i)(1)).Shapes(pptPres.Slides(chartMap(i)(1)).Shapes.Count)
            .LockAspectRatio = -1 ' msoTrue对应值为-1
            .Height = 250
            If pastePos = 1 Then
                .Left = 50
            Else
                .Left = 350
            End If
            .Top = 100
        End With
    Next i
    
    Set cht = Nothing
    Set pptPres = Nothing
    Set PowerPointApp = Nothing
    MsgBox "导出完成！"
End Sub

• 若不清楚Graphs工作表内图表的序号，可运行以下代码查看所有图表的序号和名称，对应修改chartMap配置即可：

Sub 查看图表序号()
    Dim cht As ChartObject
    For Each cht In Worksheets("Graphs").ChartObjects
        MsgBox "图表序号：" & cht.Index & "，图表名称：" & cht.Name
    Next cht
End Sub

• 代码中的图表高度、边距数值可根据你的PPT模板尺寸自行调整。
• 确保PPT模板和当前Excel文件放在同一个文件夹内，命名为My_template.pptx，如果路径或名称不同，修改strpath对应的取值即可。

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