从Excel复制到Powerpoint错误 [英] Copy from Excel to Powerpoint error
问题描述
再次借助于stackoverflow中的各种资源,我一直在使用下面的代码将信息从Excel 2010复制到Powerpoint 2010幻灯片中。我重复中间的代码约20次为我的幻灯片。
Again with the help of the kind resources around stackoverflow, I have been using the code below to copy information from Excel 2010 into Powerpoint 2010 slides. I repeat the code in the middle about 20 times for my slides.
我开始间歇地获取消息
Run-time error -2147417851 (80010105) method 'pastespecial' of object 'shapes' failed
在这一行:
Set ppShape = PPSlide.Shapes.PasteSpecial(DataType:=ppPasteOLEObject, Link:=msoFalse)
以下是代码的其余部分:
Here is the rest of the code:
Sub PPTReport()
Dim PPApp As PowerPoint.Application
Dim PPSlide As PowerPoint.Slide
Dim PPPres As PowerPoint.Presentation
Set PPApp = CreateObject("Powerpoint.Application")
Dim SlideNum As Integer
Dim wbk As Workbook
'Dim ppShape As PowerPoint.Shape
Dim ppShape As Object
Set XLApp = GetObject(, "Excel.Application")
''define input Powerpoint template
Dim strPresPath As String, strExcelFilePath As String, strNewPresPath As String
''# Change "strPresPath" with full path of the Powerpoint template
strPresPath = ThisWorkbook.Path & "\template\template.ppt"
''# Change "strNewPresPath" to where you want to save the new Presentation to be created
strNewPresPath = ThisWorkbook.Path & "\electra_status_report-" & Format(Date, "yyyy-mm-dd") & ".ppt"
Set PPPres = PPApp.Presentations.Open(strPresPath)
PPPres.Application.Activate
PPApp.Visible = True
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''define destination slide
SlideNum = 1
PPPres.Slides(SlideNum).Select
Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
''define source sheet
strFirstFile = ThisWorkbook.Path & "\workstreams\ws1.xlsx"
Set wbk = Workbooks.Open(strFirstFile)
wbk.Sheets("WS1").Activate
Cells(1, 1).Activate
'copy/paste from
XLApp.Range("WS1Dash").Copy
Set ppShape = PPSlide.Shapes.PasteSpecial(DataType:=ppPasteOLEObject, Link:=msoFalse)
'place size and shape 72 ppi
ppShape.Width = 718
ppShape.Left = 1
ppShape.Top = 16
PPPres.Application.Activate
wbk.Sheets("WS1").Activate
Cells(1, 1).Copy
wbk.Close savechanges:=False
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''define destination slide
SlideNum = 2
PPPres.Slides(SlideNum).Select
Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
''define source sheet
strFirstFile = ThisWorkbook.Path & "\workstreams\ws2.xlsx"
Set wbk = Workbooks.Open(strFirstFile)
wbk.Sheets("WS2").Activate
Cells(1, 1).Activate
'copy/paste from
XLApp.Range("WS2Dash").Copy
Set ppShape = PPSlide.Shapes.PasteSpecial(DataType:=ppPasteOLEObject, Link:=msoFalse)
'place size and shape 72 ppi
ppShape.Width = 718
ppShape.Left = 1
ppShape.Top = 16
PPPres.Application.Activate
wbk.Sheets("WS2").Activate
Cells(1, 1).Copy
wbk.Close savechanges:=False
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Sheets("Dashboard").Activate
' Close presentation
PPPres.SaveAs strNewPresPath
PPPres.Close
' Quit PowerPoint
PPApp.Quit
' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
AppActivate "Microsoft Excel"
MsgBox "Presentation Created", vbOKOnly + vbInformation
End Sub
有关如何解决此错误的任何想法? / p>
Any thoughts on how to resolve this error?
推荐答案
您正在面对的问题是因为复制需要时间,下一行将被执行,并且没有找到
The problem that you are facing is because the copying is taking time and the next line is getting executed and it doesn't find anything in the clipboard to paste.
处理此问题的两种方法
方式1
Way 1
XLApp.Range("WS1Dash").Copy
DoEvents
Set ppShape = PPSlide.Shapes.PasteSpecial(DataType:=ppPasteOLEObject, Link:=msoFalse)
方式2
XLApp.Range("WS1Dash").Copy
Wait 2
Set ppShape = PPSlide.Shapes.PasteSpecial(DataType:=ppPasteOLEObject, Link:=msoFalse)
并将其粘贴到您的程序的底部
And paste this at the bottom of your procedure
Private Sub Wait(ByVal nSec As Long)
nSec = nSec + Timer
While nSec > Timer
DoEvents
Wend
End Sub
没有帮助...
这篇关于从Excel复制到Powerpoint错误的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!