从Excel到Powerpoint的VBA复制和粘贴图表

Question

好的，所以我尝试编写一些代码，这些代码将首先在excel上创建大约15个图形，然后在powerpoint上打开一个模板并将这些图形粘贴到每张幻灯片中。 我遇到了multiplt问题，但我似乎真的找不到原因。 当我按f8逐行运行代码时，它工作正常，但第二次运行整个宏，则发生了一些事情：1）它会随机决定不将某些图形粘贴到页面上2）尝试引用粘贴时通过诸如.shapes（3）或shapes（slide.shapes.count）之类的代码进行图形化处理，我收到一条错误消息，告知shapes.item：整数3超出范围1至2 3）我正在使用CommandBars.ExecuteMso（“ PasteSourceFormatting”）根据需要保留格式来粘贴图形，我可以粘贴图形并以其他方式放置它们，但它并不能保留所需的格式。

有什么建议么？

这是代码：

   Sub PowerPointPresentation()
   Dim PPT As Object
   Set PPT = CreateObject("PowerPoint.Application")
   PPT.Visible = True
   PPT.Presentations.Open filename:="P:\My Documents\CM Presentation Macro\CM Presentation Template.pptm"
'copy_chart "sheet_name", 2  ' Name of the sheet to copy graph and slide number the graph is to be pasted in

Dim PPApp As Object
Dim PPPres As Object
Dim PPSlide As Object

Set PPApp = CreateObject("Powerpoint.Application")
'Set PPSlide = CreateObject("Powerpoint.Slide")

Set PPApp = GetObject(, "Powerpoint.Application")
Set PPPres = PPApp.ActivePresentation

'Slide 1
PPApp.ActiveWindow.View.GotoSlide (1)
Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
PPSlide.Shapes(1).TextFrame.TextRange.Text = r & " Country Review  YTD " & Year(Now())

'Slide 2
PPApp.ActiveWindow.View.GotoSlide (2)
Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
PPSlide.Shapes(1).TextFrame.TextRange.Text = r & " Country Review  YTD " & Year(Now())

'Slide 3
Worksheets("Pivots").ChartObjects(1).Select
ActiveChart.ChartArea.Copy

i = Pivots.Range("G14").Text
j = Pivots.Range("H14").Text

PPApp.ActiveWindow.View.GotoSlide (3)
Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
With PPSlide
.Shapes(1).TextFrame.TextRange.Text = r & " TCV YTD " & Year(Now()) - 1 & " and " & Year(Now()) & " - by Sector"
.Shapes(2).TextFrame.TextRange.Text = "Totals:" & Year(Now()) - 1 & ":" & i & "" & Year(Now()) & ":" & j
End With
PPApp.CommandBars.ExecuteMso ("PasteSourceFormatting")

'Slide 4
Worksheets("Pivots").ChartObjects(2).Select
ActiveChart.ChartArea.Copy

i = Pivots.Range("V14").Text
j = Pivots.Range("W14").Text

PPApp.ActiveWindow.View.GotoSlide (4)
Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
With PPSlide
.Shapes(1).TextFrame.TextRange.Text = r & " TCV YTD " & Year(Now()) - 1 & " and " & Year(Now()) & " - by Type"
.Shapes(2).TextFrame.TextRange.Text = "Totals:" & Year(Now()) - 1 & ":" & i & "" & Year(Now()) & ":" & j
End With
PPApp.CommandBars.ExecuteMso ("PasteSourceFormatting")

'Slide 5
Worksheets("Pivots").Range("New_TCV_YTD2014[#All]").Copy

PPApp.ActiveWindow.View.GotoSlide (5)
Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
With PPSlide
PPApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
End With

Worksheets("Pivots").ChartObjects(3).Select
ActiveChart.ChartArea.Copy

PPApp.ActiveWindow.View.GotoSlide (5)
Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
With PPSlide
.Shapes(1).TextFrame.TextRange.Text = r & " New TCV by AM YTD " & Year(Now())
PPApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
End With

' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing

End Sub

Answer 1

代替这个：

PPApp.ActiveWindow.View.GotoSlide (1)
Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)

尝试这个：

Set PPSlide = PPPres.Slides(1)

无需转到幻灯片。

粘贴图表时，请尝试：

Dim oSh As Shape
With ActivePresentation.Slides(1)
    Set oSh = .Shapes.PasteSpecial(ppPasteOLEObject)(1)
    ' And now you can use oSh to position/size/otherwise work with the chart
End With

您可能可以执行此操作，而不是在工作簿中选择任何内容：

Worksheets("Pivots").ChartObjects(2).Copy

如果您不选择（在任何一个应用程序中）应用程序，您的代码运行速度将加快10到41万亿次之间，并且更加可靠。 仅此一点就可以解决其他问题。 该应用程序可能正在忙于尝试在您请求的选择操作之后刷新，而无法跟上您要求它下一步执行的其他操作。