Question

好的，所以我尝试编写一些代码，首先在excel上创建大约15个图形，然后在powerpoint上打开模板并将这些图形粘贴到每个幻灯片中。我虽然遇到了多重问题，但我似乎无法找到原因。当我通过按f8逐行完成代码时，它工作正常，但第二个我运行整个宏，发生了一些事情： 1）随机决定不在页面上粘贴一些图形 2）当试图通过.shapes（3）或形状（slide.shapes.count）等代码引用粘贴的图形时，我收到一条错误消息，说明shapes.item：整数3超出范围1到2 3）我使用CommandBars.ExecuteMso（＆＃34; PasteSourceFormatting＆＃34;）粘贴图形，因为我需要保留格式，我可以粘贴图形并将它们定位为另一种方式，但它不会保持我需要的格式。

有什么建议吗？

以下是代码：

   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

如果你没有选择任何东西（在任一应用程序中），你的代码将在十到四十一倍之间运行，并且会更加可靠。仅这一点就可以解决另一个问题;应用程序可能正忙于尝试在您要求的选择操作后刷新，并且无法跟上您要求它下一步执行的其他操作。

VBA将图表从excel复制并粘贴到powerpoint

1 个答案: