excel - 从 excel 粘贴到 powerpoint 时 VBA 中的运行时错误

Question

我有一些相当简单的 VBA 代码，可以一次将 1 行或 2 行从 Excel 复制到连续的 PowerPoint 幻灯片上。

当我在调试模式下逐行运行时，代码运行良好。但是，当我在不手动执行的情况下运行它时，我会在 while 循环的早期（通常在第 2 次或第 3 次迭代前后）得到一个错误。

这是代码：

Private Sub CommandButtonExportToPowerPoint_Click()


Dim rng As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object

Dim lFirstRow As Long
Dim lLastRow As Long
Dim sRangeString As String

Dim lNumberOfPptSlidesToAdd As Long

lFirstRow = 84
lLastRow = Cells(Rows.Count, 1).End(xlUp).Row

lNumberOfPptSlidesToAdd = (lLastRow - lFirstRow) / 2

sRangeString = "B" & lFirstRow & ":B" & lLastRow & ",L" & lFirstRow & ":L" & lLastRow & ",M" & lFirstRow & ":M" & lLastRow & ",N" & lFirstRow & ":N" & lLastRow

Set rng = ThisWorkbook.ActiveSheet.Range(sRangeString)
rng.Select

On Error Resume Next


Set PowerPointApp = GetObject(class:="PowerPoint.Application")


Err.Clear


If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")


If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If

On Error GoTo 0


Application.ScreenUpdating = False
PowerPointApp.Visible = True
PowerPointApp.Activate


Set myPresentation = PowerPointApp.Presentations.Open("C:\some\path\to\existingppt\test.pptx")
rng.Copy

Sheets("Sheet1").Range("E1").PasteSpecial Paste:=xlPasteValues
Sheets("Sheet1").Range("E1").PasteSpecial Paste:=xlPasteFormats
Dim lCurrentFirstRowToCopy As Long
lCurrentFirstRowToCopy = 2 + 1

lLastRow = lLastRow - lFirstRow + 1

Dim lPowerPointCurrentSlide As Long
lPowerPointCurrentSlide = 18

Dim sFirstRowValue, sSecondRowValue As String



While lCurrentFirstRowToCopy <= lLastRow

    If Sheets("Sheet1").Range("E" & lCurrentFirstRowToCopy).MergeCells = True Then
        MsgBox ("Cell E" & lCurrentFirstRowToCopy & " is merged: " & Sheets("Sheet1").Range("E" & lCurrentFirstRowToCopy).MergeCells)
    End If

    sFirstRowValue = Sheets("Sheet1").Range("E" & lCurrentFirstRowToCopy).Value
    sSecondRowValue = Sheets("Sheet1").Range("E" & lCurrentFirstRowToCopy + 1).Value
    If Left(sFirstRowValue, 5) = Left(sSecondRowValue, 5) Then
        Set rng = Sheets("Sheet1").Range("E" & lCurrentFirstRowToCopy & ":H" & lCurrentFirstRowToCopy + 1)
        lCurrentFirstRowToCopy = lCurrentFirstRowToCopy + 2
    Else
        Set rng = Sheets("Sheet1").Range("E" & lCurrentFirstRowToCopy & ":H" & lCurrentFirstRowToCopy)
        lCurrentFirstRowToCopy = lCurrentFirstRowToCopy + 1
    End If
    Application.CutCopyMode = True
    rng.Copy
    myPresentation.Slides(lPowerPointCurrentSlide).Select
    PowerPointApp.CommandBars.ExecuteMso "Paste"
    Application.CutCopyMode = False
    lPowerPointCurrentSlide = lPowerPointCurrentSlide + 1

Wend


rng.Clear





End Sub

如前所述，当“实时”运行代码时，即不单步执行，代码总是在任何一行都失败

myPresentation.Slides(lPowerPointCurrentSlide).Select

或线

PowerPointApp.CommandBars.ExecuteMso "Paste"

我得到的错误通常是这个：运行时错误-2147023170：自动化错误：远程过程调用失败

但是，有时我也会收到运行时错误 462 甚至运行时错误 -2147467259（对象 '_CommandBars' 的方法 'ExecuteMso' 失败。

它在单步执行代码时起作用的事实使我认为它可能与时间/进程优先级有关，但是添加 Application.Wait 语句以等待 10 秒并不能解决此问题。

任何帮助表示赞赏！

标签： excelvbapowerpoint

Answer 1

我的回忆是和/或粘贴操作是异步的，所以经常发生的情况是它在下一次迭代时还ExecuteMso没有完成粘贴。我不是 100% 确定这会解决问题，但我会尝试这样的事情，希望确保在继续循环之前完成粘贴。

Dim numShapes as Long ' get the current number of shapes on the slide
Dim sld as PowerPoint.Slide
Set sld = myPresentation.Slides(lPowerPointCurrentSlide)
sld.Select
numShapes = sld.Shapes.Count
PowerPointApp.CommandBars.ExecuteMso "Paste"
While sld.Shapes.Count < numShapes + 1
    DoEvents
Wend
lPowerPointCurrentSlide = lPowerPointCurrentSlide + 1