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

Question

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

当我在 Debug模式下逐行运行时，代码运行良好。但是，当我在不手动执行的情况下运行它时，我很早就在 while 循环中遇到错误( 通常在第二次或第三次迭代 左右)。

这是代码:

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"

我得到的错误通常是这个:Run-time error -2147023170: Automation Error: The remote procedure call failed

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

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

任何帮助表示赞赏!

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