在从Excel复制到PowerPoint时，VBA出现运行时错误

Question

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

在调试模式下逐行运行该代码时，代码能够完美执行。然而，当我不手动逐步运行它时，在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"

我通常遇到的错误是这个：运行时错误 -2147023170: 自动化错误：远程过程调用失败。但有时我也会遇到运行时错误462，甚至是运行时错误-2147467259（对象'_CommandBars'的方法'ExecuteMso'失败）。

当我逐步执行代码时它能正常工作，这使我认为它可能与时间/进程优先级有关，但添加Application.Wait语句等待10秒并没有解决问题。

欢迎提供任何帮助！

- ChrisC

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

- David Zemens

---

嘿，David，谢谢。我实现了你的方法，有时候它能正常工作，但不总是如此。我想从第18张幻灯片开始粘贴，所以在循环之前，我将lPowerPointCurrentSlide设置为18。大约70%的时间，宏都能正常工作，顺利地从第18张幻灯片开始（18、19、20等）粘贴正确的信息，直到循环正确终止... - ChrisC

然而，另外约30%的时间，宏似乎忽略了我想从第18张幻灯片开始的要求。相反，它从第1张幻灯片开始，将我想要放在第18张幻灯片上的信息复制到第1张幻灯片上，然后就不再继续执行宏（没有任何崩溃或类似的情况）。因此，总的来说，有70%的时间我得到了我想要的结果（正确地将不同的信息复制到第18、19、20等幻灯片上），而另外30%的时间，我只得到了应该出现在第18张幻灯片上的信息，但由于某种原因，这些信息实际上出现在第1张幻灯片上... 有什么想法吗？ - ChrisC

不行。你需要使用一些断点和 F8 键来逐步执行代码并查看内部发生了什么。没有你的文件，我无法调试。 - David Zemens

Answer 2

正如David所指出的，这是一个时间问题。以下是我解决这类问题的方法。首先进行睡眠声明：

Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)

然后在有问题的那一行添加错误检查：

TryPaste1:
  On Error GoTo TooFastPaste1
  .InsertAfter(vbCr).PasteSpecial msoClipboardFormatPlainText
  On Error GoTo 0

在Exit Sub语句之后，添加Sleep语句：

TooFastPaste1:
  Sleep 10
  Resume TryPaste1

这将以10毫秒的间隔重试粘贴操作，直到最终成功。

- John Korchok

---

嗨John，感谢你的帮助。你能再详细解释一下吗？你提到的Exit Sub语句放在哪里？我应该把TooFastPaste1块放在哪里？我已经按照你的建议尝试实现了，但执行Resume TryPaste1时出现了“运行时错误'20'：无错误恢复”的错误。 - ChrisC

当一个子程序包含错误捕获功能时，通常会将错误代码放在底部，并在其前面加上Exit Sub语句，以便于正常处理子程序时可以退出代码而不必运行所有的错误代码。TooPastePaste1块紧随Exit Sub语句之后。此运行时错误是因为您没有包括Exit Sub语句，所以执行过程在没有任何错误的情况下经过了错误处理。 - John Korchok