从 Excel 复制到 Powerpoint 错误

Posted 2023-02-19

【中文标题】从 Excel 复制到 Powerpoint 错误

【英文标题】：Copy from Excel to Powerpoint error

【发布时间】：2013-09-21 23:53:34

【问题描述】：

再次借助有关 *** 的资源，我一直在使用下面的代码将 Excel 2010 中的信息复制到 Powerpoint 2010 幻灯片中。我为我的幻灯片重复了大约 20 次中间的代码。

我开始间歇性地收到消息

Run-time error -2147417851 (80010105) method 'pastespecial' of object 'shapes' failed

在这一行：

Set ppShape = PPSlide.Shapes.PasteSpecial(DataType:=ppPasteOLEObject, Link:=msoFalse)

剩下的代码如下：

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

关于如何解决此错误的任何想法？

【参考方案1】：

您面临的问题是因为复制需要时间，并且下一行正在执行，并且在剪贴板中找不到任何要粘贴的内容。

解决这个问题的两种方法

方式 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)

并将其粘贴到程序的底部

Private Sub Wait(ByVal nSec As Long)
    nSec = nSec + Timer
    While nSec > Timer
        DoEvents
    Wend
End Sub

让我知道这是否没有帮助......

【讨论】：

非常感谢！方式 1 中的 DoEvents 似乎正在工作，至少到目前为止 :)

【参考方案2】：

我遇到了同样的问题，它发生在我试图在没有 PowerPoint 引用的情况下从 Excel 导出到 PowerPoint 时，使用它作为对象。棘手的是，有时它会起作用，有时它不会。所以经过一些测试后，我发现它取决于 PowerPoint 视图的状态，是显示缩略图还是正常的幻灯片视图。

要修复它，请在粘贴之前将 ViewType 设置为正常。

PPAP.ActiveWindow.ViewType = ppViewNormal

或

PPAP.ActiveWindow.ViewType = 9

PPAP 代表 PowerPoint 应用程序对象。

【讨论】：

该ppt已经处于正常模式。但在 Excel 2016 中仍然出现错误。

我使用的是 Excel 2013，没有使用 Excel 2016 检查。也许是类似的东西使 PowerPoint 无法粘贴它。你发现它已经如何解决了吗？

不。这是剪贴板复制粘贴时间问题。多年来仍然存在。 MS 未提供解决方案。