Ein liebes Hallo an alle Besucher!

Ich habe folgendes Problem: In nachstehendem Excel-Code kommt ab und an der Fehler H80048240 -2148240 oder auch Laufzeitfehler 1004. Ich habe das Programm etwas vereinfacht und hier angehängt. Das Programm exportiert Tabellenausschnitte in eine Powerpoint-Anwendung aus Excel heraus und zwar drei Ausschnitte auf eine Powerpoint-Seite(slide).
Zum Testen empfiehlt es sich die Spalten A-D einfach mit hochzählenden Nummern zu füllen, damit man im PowerPoint sieht wo genau das Programm ausgestiegen ist. Bitte auch die erste Tabelle nach "Test" umbenennen.

Leider kommt der Fehler nicht immer und auch nicht an der selben Stelle aber in der gleichen Sub . Daher habe ich den Excel - VBA - Code hier angehängt. Vielleicht fällt ja den Profis hier auf was zur Vermeidung des Fehlers geändert werden muss. (Copy oder CopyPicture oder Ähnliches ???).

Der Fehler erscheint auch erst ab der Excel-Version 2010. Dort tritt er selten auf. In der Verison 2016 kommt er öfters und das Programm bricht ab.

Option Explicit
Dim ppApp As PowerPoint.Application
Dim ppPres As PowerPoint.Presentation
Dim ppSlide As PowerPoint.Slide
Public Sub ClearClipboard()
    Sheets("Test").Range("X40").Copy
    Application.CutCopyMode = False
End Sub
Private Sub Zeichne_Tabelle(ppApp As Object, anfang As String, ende As String, top As Integer,  _
left As Integer, seite As Integer)  ', width As Integer, height As Integer)

    Set ppSlide = ppPres.Slides(1)
    Sheets("Test").Activate
    Sheets("Test").Range(anfang + ":" + ende).Select     

    Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture   
    
    ppApp.Visible = msoTrue
    ppApp.ActiveWindow.View.GotoSlide 1
    
    ppSlide.Shapes.Paste.Select
    Call DieseArbeitsmappe.ClearClipboard
    
    ppApp.Visible = msoTrue
    With ppApp.ActiveWindow.Selection.ShapeRange  ' Definition der Position
        .top = top
        .left = left
        .Width = .Width
        .Height = .Height * 1.25
    End With

    Set ppSlide = Nothing
End Sub
Sub ExcelNachPptClick()
        
    ' Variablen vereinbaren
    Dim ws As Worksheet
    Dim i As Integer
    Dim j As Integer
    
    Set ws = Sheets("Test")
    
    ' Allgemein PowerPoint initialisieren
    Set ppApp = CreateObject("Powerpoint.Application")
    Set ppPres = ppApp.Presentations.Add
    
    For i = 1 To 300
    
        ppApp.Visible = msoTrue
        ppPres.Slides.Add 1, ppLayoutBlank
        ppPres.Slides(1).Select
        ppApp.Visible = msoTrue
        ppApp.ActiveWindow.View.GotoSlide 1
    
        j = i + 4
        Call Zeichne_Tabelle(ppApp, "A" & i, "D" & j, 100, 100, i)
        Call Zeichne_Tabelle(ppApp, "A" & i, "D" & j, 200, 100, i)
        Call Zeichne_Tabelle(ppApp, "A" & i, "D" & j, 300, 100, i)
    Next i
    
    Set ppApp = Nothing
    Set ppPres = Nothing
End Sub

Für jede Idee bin ich dankbar.

Viele Grüße
Karin