Иногда получают ошибку во время выполнения в коде, который копирует диапазоны от листа Excel до PowerPoint

Question

Я построил следующий код:

Sub Metrics()    
    Application.CutCopyMode = False    
    Application.ScreenUpdating = False

    Dim pptapp As Object
    Dim wholeppt As Object
    Dim sld As Object
    Dim rng As Object
    Dim shp As Object
    Dim x As Integer

    Set pptapp = GetObject(class:="PowerPoint.Application")
    Set wholeppt = pptapp.ActivePresentation
    Set sld = wholeppt.Slides

    pptapp.Activate

    Set Rev = ThisWorkbook.Worksheets("CIS Story").Range("E1:F3")
    Set GC = ThisWorkbook.Worksheets("CIS Story").Range("E4:F6")
    Set GM = ThisWorkbook.Worksheets("CIS Story").Range("E7:F9")
    Set RPE = ThisWorkbook.Worksheets("CIS Story").Range("E10:F12")
    Set SPE = ThisWorkbook.Worksheets("CIS Story").Range("E13:F15")
    Set DDC = ThisWorkbook.Worksheets("CIS Story").Range("K1:L3")
    Set OPAS = ThisWorkbook.Worksheets("CIS Story").Range("E16:F18")
    Set BHC = ThisWorkbook.Worksheets("CIS Story").Range("K4:L6")
    Set A = ThisWorkbook.Worksheets("CIS Story").Range("K10:L12")
    Set TTP = ThisWorkbook.Worksheets("CIS Story").Range("K13:L15")
    Set SU = ThisWorkbook.Worksheets("CIS Story").Range("K7:L9")

    pptapp.ActiveWindow.View.GotoSlide 12

    Rev.Copy

    Set rng = sld(12).Shapes.PasteSpecial(DataType:=ppPaste)

    Set shp = rng(1)

         shp.Left = 0
         shp.Top = 65
         shp.Height = 60
         shp.Width = 125
    Application.CutCopyMode = False

    pptapp.ActiveWindow.View.GotoSlide 13

    GC.Copy

    Set rng = sld(13).Shapes.PasteSpecial(DataType:=ppPaste)

    Set shp = rng(1)

       shp.Left = 0
       shp.Top = 65
       shp.Height = 60
       shp.Width = 125

    Application.CutCopyMode = False

    pptapp.ActiveWindow.View.GotoSlide 14

    GM.Copy

    Set rng = sld(14).Shapes.PasteSpecial(DataType:=ppPaste)
    Set shp = rng(1)

       shp.Left = 0
       shp.Top = 65
       shp.Height = 60
       shp.Width = 125

    Application.CutCopyMode = False

    pptapp.ActiveWindow.View.GotoSlide 15

    RPE.Copy

    Set rng = sld(15).Shapes.PasteSpecial(DataType:=ppPaste)
    Set shp = rng(1)

       shp.Left = 0
       shp.Top = 65
       shp.Height = 60
       shp.Width = 125

    Application.CutCopyMode = False

    pptapp.ActiveWindow.View.GotoSlide 16

    SPE.Copy

    Set rng = sld(16).Shapes.PasteSpecial(DataType:=ppPaste)
    Set shp = rng(1)

       shp.Left = 0
       shp.Top = 65
       shp.Height = 60
       shp.Width = 125

    Application.CutCopyMode = False

    pptapp.ActiveWindow.View.GotoSlide 17

    BHC.Copy

    Set rng = sld(17).Shapes.PasteSpecial(DataType:=ppPaste)
    Set shp = rng(1)

       shp.Left = 0
       shp.Top = 65
       shp.Height = 60
       shp.Width = 125

    Application.CutCopyMode = False

    pptapp.ActiveWindow.View.GotoSlide 18

    SU.Copy

    Set rng = sld(18).Shapes.PasteSpecial(DataType:=ppPaste)
    Set shp = rng(1)

       shp.Left = 0
       shp.Top = 65
       shp.Height = 60
       shp.Width = 125

    Application.CutCopyMode = False

    pptapp.ActiveWindow.View.GotoSlide 19

    OPAS.Copy

    Set rng = sld(19).Shapes.PasteSpecial(DataType:=ppPaste)
    Set shp = rng(1)

       shp.Left = 0
       shp.Top = 65
       shp.Height = 60
       shp.Width = 125

    Application.CutCopyMode = False

    pptapp.ActiveWindow.View.GotoSlide 20

    DDC.Copy

    Set rng = sld(20).Shapes.PasteSpecial(DataType:=ppPaste)
    Set shp = rng(1)

       shp.Left = 0
       shp.Top = 65
       shp.Height = 60
       shp.Width = 125

    Application.CutCopyMode = False

    pptapp.ActiveWindow.View.GotoSlide 21

    A.Copy

    Set rng = sld(21).Shapes.PasteSpecial(DataType:=ppPaste)
    Set shp = rng(1)

       shp.Left = 0
       shp.Top = 65
       shp.Height = 60
       shp.Width = 125

    Application.CutCopyMode = False

    pptapp.ActiveWindow.View.GotoSlide 22

    TTP.Copy

    Set rng = sld(22).Shapes.PasteSpecial(DataType:=ppPaste)
    Set shp = rng(1)

       shp.Left = 0
       shp.Top = 65
       shp.Height = 60
       shp.Width = 125

    Application.CutCopyMode = False

    Set sld = Nothing
    Set wholeppt = Nothing
    Set pptapp = Nothing
    Set rng = Nothing
    Set shp = Nothing
End Sub

Иногда он запускается успешно, но в большинстве случаев возникает следующая ошибка:

Ошибка во время выполнения '-2147188160 (80048240) ': Shapes.PasteSpecial: неверный запрос. Буфер обмена пуст или содержит данные, которые нельзя вставить сюда.

Пожалуйста, помогите мне устранить ошибку, так как это работа в офисе.

Answer 1

У меня была та же проблема, это код, который работает для меня. У него есть дополнительная команда DoEvents (для ее замедления) и дополнительная уловка, чтобы повторить попытку в случае неудачи первого. Это вместе работает для меня.

Ура, Коэн

rng.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
DoEvents
Set Shp1 = Nothing
On Error Resume Next
Set Shp1 = PPslide.Shapes.Paste
On Error GoTo 0
If Not Shp1 Is Nothing Then
    'OK
    Debug.Print XlsNm & "-OK"
Else
    Debug.Print XlsNm & "-ERROR"
    rng.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    DoEvents
    Set Shp1 = PPslide.Shapes.Paste
End If
'Err.Clear: On Error GoTo 0
On Error GoTo 0