Hallo und Guten Mittag,
ich übertrage mittels mehreren Unterprogrammen Tabellen aus Excel mit der Copy.Picture + Paste Methode. Dabei bekomme ich immer folgende Fehlermeldung: Laufzeitfehler 4605: Diese Methode oder Eigenschaft ist nicht verfügbar, weil die Zwischenablage entweder leer oder ungültig ist. Der Fehler tritt bei mehrmaliger Ausführung des Makros immer an anderen Stellen auf (meinst beim Paste-Befehl). Kann es sein, dass die Zwischenablage voll ist und er deswegen nichts mehr kopieren kann? Eines der Unterprogramme habe ich euch beispielhaft angefügt (sind alle gleich aufgebaut, es werden nur andere Tabellenblätter kopiert)
With ThisWorkbook.Worksheets("Input")
If Wagen6 = 1 Then
Set Liste = Sheets("Input").Range("D82")
Liste.AutoFilter
Liste.AutoFilter Field:=1, Criteria1:="1", VisibleDropDown:=False
If objDocument.Bookmarks.Exists("Wagen6") = True Then
.Range("Wagen6").CopyPicture 1, 2
Set objWordRange = objDocument.Bookmarks("Wagen6").Range
objWordRange.Paste
Set objWordRange = Nothing
End If
Liste.AutoFilter Field:=1
Set Liste = Sheets("Input").Range("D133")
Liste.AutoFilter Field:=1, Criteria1:="1", VisibleDropDown:=False
If objDocument.Bookmarks.Exists("Wagen6") = True Then
.Range("Wagen6").CopyPicture 1, 2
Set objWordRange = objDocument.Bookmarks("Wagen6").Range
objWordRange.Paste
Set objWordRange = Nothing
End If
Liste.AutoFilter Field:=1
End If
If Wagen5 = 1 Then
Set Liste = Sheets("Input").Range("AJ82")
Liste.AutoFilter
Liste.AutoFilter Field:=1, Criteria1:="1", VisibleDropDown:=False
If objDocument.Bookmarks.Exists("Wagen5") = True Then
.Range("Wagen5").CopyPicture 1, 2
Set objWordRange = objDocument.Bookmarks("Wagen5").Range
objWordRange.Paste
Set objWordRange = Nothing
End If
Liste.AutoFilter Field:=1
Set Liste = Sheets("Input").Range("AJ133")
Liste.AutoFilter
Liste.AutoFilter Field:=1, Criteria1:="1", VisibleDropDown:=False
If objDocument.Bookmarks.Exists("Wagen5") = True Then
.Range("Wagen5").CopyPicture 1, 2
Set objWordRange = objDocument.Bookmarks("Wagen5").Range
objWordRange.Paste
Set objWordRange = Nothing
End If
Liste.AutoFilter Field:=1
End If
If Wagen4 = 1 Then
Set Liste = Sheets("Input").Range("BO82")
Liste.AutoFilter Field:=1, Criteria1:="1", VisibleDropDown:=False
If objDocument.Bookmarks.Exists("Wagen4") = True Then
.Range("Wagen4").CopyPicture 1, 2
Set objWordRange = objDocument.Bookmarks("Wagen4").Range
objWordRange.Paste
Set objWordRange = Nothing
End If
Liste.AutoFilter Field:=1
Set Liste = Sheets("Input").Range("BO133")
Liste.AutoFilter
Liste.AutoFilter Field:=1, Criteria1:="1", VisibleDropDown:=False
If objDocument.Bookmarks.Exists("Wagen4") = True Then
.Range("Wagen4").CopyPicture 1, 2
Set objWordRange = objDocument.Bookmarks("Wagen4").Range
objWordRange.Paste
Set objWordRange = Nothing
End If
'das Spiel wiederholt sich nach dem Schema bis Wagen1...
End With
End Sub