從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 秒並沒有解決這個問題。

任何幫助表示贊賞！

Answer 1

我記得ExecuteMso和/或 Paste 操作是異步的，所以經常發生的情況是它在進入下一次迭代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

Answer 2

正如大衛所指出的，這是一個時間問題。 這是我解決此類問題的方法。 首先做一個睡眠聲明：

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 毫秒的間隔重試粘貼操作，直到它最終成功。