使用VBA将Excel图表粘贴到PPT

Question

我正在尝试使用以下 VBA 代码将图表从 excel 复制到 ppt。但我无法弄清楚如何使用粘贴特殊功能（保留源格式和链接数据）将图形复制为图表。我的代码正在将图表复制为图片。

Option Explicit

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

    ' Open PowerPoint presentation
    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
    ' Open PowerPoint presentation and set the slide
    Set myPresentation = PowerPointApp.Presentations.Open(Filename:="C:\Users\krps\Downloads\In Stock_Support_WSR_12_23_2023_V1.pptx")
    Set mySlide = myPresentation.Slides(4)

    ' Copy and paste the first chart
    ThisWorkbook.Worksheets("KSC_Incident_Summary").ChartObjects("Graph1").Chart.CopyPicture
    mySlide.Shapes.Paste
    Application.CutCopyMode = False

    ' Delete all charts in the slide
    For i = mySlide.Shapes.Count To 1 Step -1
        If mySlide.Shapes(i).Type = msoChart Then
            mySlide.Shapes(i).Delete
        End If
    Next i
    Application.CutCopyMode = False

    ' Set chart position
    Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
    With myShape
        .Left = 50
        .Top = 90
        .Width = 800
        .Height = 290
    End With

    ' Set the slide for the second chart
    Set mySlide = myPresentation.Slides(4)

    ' Copy and paste the second chart
    ThisWorkbook.Worksheets("L3 Transfer Trends").ChartObjects("Graph2").Chart.CopyPicture
    mySlide.Shapes.Paste
    Application.CutCopyMode = False

    ' Set chart position for the second chart
    Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
    With myShape
        .Left = 500
        .Top = 92
        .Width = 287
        .Height = 290
    End With
    
'Slide 7
    Set mySlide = myPresentation.Slides(7)

    ' Copy and paste the first chart
    ThisWorkbook.Worksheets("DSR").ChartObjects("Graph3").Chart.CopyPicture
    mySlide.Shapes.Paste
    Application.CutCopyMode = False

    ' Delete all charts in the slide
    For i = mySlide.Shapes.Count To 1 Step -1
        If mySlide.Shapes(i).Type = msoChart Then
            mySlide.Shapes(i).Delete
        End If
    Next i
    Application.CutCopyMode = False

    ' Set chart position
    Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
    With myShape
        .Left = 52
        .Top = 94
        .Width = 530
        .Height = 270
    End With

    ' Set the slide for the second chart
    Set mySlide = myPresentation.Slides(7)

    ' Copy and paste the second chart
    ThisWorkbook.Worksheets("System vs Manual Metrics").ChartObjects("Graph4").Chart.CopyPicture
    mySlide.Shapes.Paste
    Application.CutCopyMode = False

    ' Set chart position for the second chart
    Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
    With myShape
        .Left = 500
        .Top = 94
        .Width = 270
        .Height = 270
    End With

    ' Activate PowerPoint
    PowerPointApp.Visible = True
    PowerPointApp.Activate
End Sub

Answer 1

尝试更换...

ThisWorkbook.Worksheets("KSC_Incident_Summary").ChartObjects("Graph1").Chart.CopyPicture

与

ThisWorkbook.Worksheets("KSC_Incident_Summary").ChartObjects("Graph1").Chart.ChartArea.Copy

对于其他人也是如此。

希望这有帮助！