使用VBA将Excel图表粘贴至PPT（保留源格式并关联数据）

问题根源 #

你的代码中使用了Chart.CopyPicture方法，该方法仅会将图表复制为图片格式，因此无法实现“保留源格式并链接数据”的可编辑图表效果。要达成需求，需要改用完整的图表对象复制+选择性粘贴链接的方式。

修改后的完整代码 #

Option Explicit

Sub CopyChartToPowerpoint()
    Dim PowerPointApp As Object
    Dim myPresentation As Object
    Dim mySlide As Object
    Dim myShape As Object
    Dim i As Integer

    ' 启动/获取PowerPoint应用
    On Error Resume Next
    Set PowerPointApp = GetObject(class:="PowerPoint.Application")
    If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
    On Error GoTo 0

    Application.ScreenUpdating = False
    
    ' 打开目标PPT文件
    Set myPresentation = PowerPointApp.Presentations.Open(Filename:="C:\Users\krps\Downloads\In Stock_Support_WSR_12_23_2023_V1.pptx")

    ' ========== 处理幻灯片4的图表 ==========
    Set mySlide = myPresentation.Slides(4)
    ' 先删除幻灯片上已有的旧图表
    For i = mySlide.Shapes.Count To 1 Step -1
        If mySlide.Shapes(i).Type = msoChart Then
            mySlide.Shapes(i).Delete
        End If
    Next i
    ' 复制并粘贴第一个图表（保留格式+链接数据）
    ThisWorkbook.Worksheets("KSC_Incident_Summary").ChartObjects("Graph1").Chart.Copy
    Set myShape = mySlide.Shapes.PasteSpecial(DataType:=ppPasteOLEObject, Link:=msoTrue)
    ' 设置图表位置大小
    With myShape
        .Left = 50
        .Top = 90
        .Width = 800
        .Height = 290
    End With
    Application.CutCopyMode = False

    ' 粘贴第二个图表到幻灯片4
    ThisWorkbook.Worksheets("L3 Transfer Trends").ChartObjects("Graph2").Chart.Copy
    Set myShape = mySlide.Shapes.PasteSpecial(DataType:=ppPasteOLEObject, Link:=msoTrue)
    With myShape
        .Left = 500
        .Top = 92
        .Width = 287
        .Height = 290
    End With
    Application.CutCopyMode = False

    ' ========== 处理幻灯片7的图表 ==========
    Set mySlide = myPresentation.Slides(7)
    ' 删除旧图表
    For i = mySlide.Shapes.Count To 1 Step -1
        If mySlide.Shapes(i).Type = msoChart Then
            mySlide.Shapes(i).Delete
        End If
    Next i
    ' 粘贴第一个图表
    ThisWorkbook.Worksheets("DSR").ChartObjects("Graph3").Chart.Copy
    Set myShape = mySlide.Shapes.PasteSpecial(DataType:=ppPasteOLEObject, Link:=msoTrue)
    With myShape
        .Left = 52
        .Top = 94
        .Width = 530
        .Height = 270
    End With
    Application.CutCopyMode = False

    ' 粘贴第二个图表到幻灯片7
    ThisWorkbook.Worksheets("System vs Manual Metrics").ChartObjects("Graph4").Chart.Copy
    Set myShape = mySlide.Shapes.PasteSpecial(DataType:=ppPasteOLEObject, Link:=msoTrue)
    With myShape
        .Left = 500
        .Top = 94
        .Width = 270
        .Height = 270
    End With
    Application.CutCopyMode = False

    ' 激活PowerPoint窗口
    PowerPointApp.Visible = True
    PowerPointApp.Activate
    Application.ScreenUpdating = True
End Sub

关键改动说明 #

• 替换复制方法：将Chart.CopyPicture改为Chart.Copy，复制完整的图表对象而非图片
• 使用选择性粘贴：通过PasteSpecial(DataType:=ppPasteOLEObject, Link:=msoTrue)实现：
  • ppPasteOLEObject：保留图表的可编辑属性和源格式
  • Link:=msoTrue：建立与Excel源数据的链接，后续Excel数据更新时PPT图表自动同步
• 调整操作顺序：先删除幻灯片上的旧图表，再粘贴新图表，避免原代码中先粘贴再删除的逻辑混乱
• 恢复屏幕更新：添加Application.ScreenUpdating = True，确保操作完成后Excel恢复正常显示

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