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

Question

我正在尝试创建一个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

Answer 1

鉴于我没有你的文件位置,我已经附加了一个例程

1. 创建了一个新的PowerPoint实例(后期绑定,因此需要为ppViewSlide定义常量等)
2. 循环遍历名为Chart1的工作表中的每个图表(根据您的示例)
3. 添加新幻灯片
4. 粘贴每个图表,然后重复

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

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