excel - 使用VBA将Excel图表粘贴到Powerpoint中

我正在尝试创建一个Excel宏，该宏可复制显示在Excel工作表上的图表，并将其粘贴(特殊粘贴)到PowerPoint中。我遇到的问题是如何将每个图表粘贴到不同的幻灯片上？我根本不知道语法。

这是我到目前为止所拥有的(它可以工作，但只会粘贴到第一张纸上):

Sub graphics3()

Sheets("Chart1").Select
ActiveSheet.ChartObjects("Chart1").Activate
ActiveChart.ChartArea.Copy
Sheets("Graphs").Select
range("A1").Select
ActiveSheet.Paste
     With ActiveChart.Parent
     .Height = 425 ' resize
     .Width = 645  ' resize
     .Top = 1    ' reposition
     .Left = 1   ' reposition
 End With

Dim PPT As Object
Set PPT = CreateObject("PowerPoint.Application")
PPT.Visible = True
PPT.Presentations.Open Filename:="locationwherepptxis"

Set PPApp = GetObject("Powerpoint.Application")
Set PPPres = PPApp.activepresentation
Set PPSlide = PPPres.slides _
    (PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)

' Copy chart as a picture
ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, _
    Format:=xlPicture

' Paste chart
PPSlide.Shapes.Paste.Select

' Align pasted chart
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True

最佳答案

鉴于我没有您要使用的文件位置，我在下面附加了一个例程

创建PowerPoint的新实例(后期绑定(bind)，因此需要为ppViewSlide等定义常量)

遍历名为Chart1的工作表中的每个图表(根据您的示例)

添加新幻灯片

粘贴每个图表，然后重复

您是否需要在导出大小之前格式化每个图表图片，还是可以更改默认图表大小？

Const ppLayoutBlank = 2
Const ppViewSlide = 1

Sub ExportChartstoPowerPoint()
    Dim PPApp As Object
    Dim chr
    Set PPApp = CreateObject("PowerPoint.Application")
    PPApp.Presentations.Add
    PPApp.ActiveWindow.ViewType = ppViewSlide
    For Each chr In Sheets("Chart1").ChartObjects
        PPApp.ActivePresentation.Slides.Add PPApp.ActivePresentation.Slides.Count + 1, ppLayoutBlank
        PPApp.ActiveWindow.View.GotoSlide PPApp.ActivePresentation.Slides.Count
        chr.Select
        ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
        PPApp.ActiveWindow.View.Paste
        PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
        PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
    Next chr
    PPApp.Visible = True
End Sub