PasteSpecial schlägt sporadisch fehl

Hallo zusammen,
dies ist mein erstes aktives Hilfegesuch hier. Gleich vorab, mir ist klar dass ich hier wahrscheinlich gleich mit einer schwer zu knackenden Kopfnuss ankomme.
Mein Problem: Der nachfolgende Code wirft sporadisch und scheinbar willkürlich 1004er Fehler bei den PasteSpecial Aufrufen.
Die Subroutine wird beim Öffnen der Arbeitsmappe aufgerufen.
Der konkrete PasteSpecial Aufruf innerhalb der Subroutine, welcher den Fehler wirft, ist immer anders und folgt keinem Muster.
Das kann ich daran erkennen welcher Bereich auf dem Blatt markiert ist, nachdem ich den Fehler bestätige.
Ich hoffe jemand hier sieht vielleicht noch was, was ich nicht sehe.
Versuchte Änderungen ohne Erfolg:
Das Arbeitsblatt immer nach dem Copy und vor dem PasteSpecial, mit Activate aktivieren.
Den Einfügebereich separat mit Select auswählen und in neuer Zeile über Selection.PasteSpecial einfügen.
Ich hoffe ihr könnt mir hier weiterhelfen.
Ich schaue mir zur Sicherheit schonmal an, wie ich das ganze mit einer PowerQuery Abfrage löse, deren Quelle ich dann ändere. Mir ist klar, dass das aus diversen Gründen wahrscheinlich eh die Bessere Lösung ist. Mir lässt aber dieses Problem keine Ruhe, weil ich auf Grund der Willkürlichkeit des Fehlers keinen Angriffspunkt für die Lösung finde.
Hier der Code:


Sub Maßnahmen_aktualisieren()
Dim rowcountSource1 As Integer
Dim rowcountSource2 As Integer
Dim rowcountSource3 As Integer
Dim rowcountTarget As Integer
Dim rowcountDifference As Integer
Dim SourceListBudgetplan1 As Excel.ListObject
Dim SourceListBudgetplan2 As Excel.ListObject
Dim SourceListBudgetplan3 As Excel.ListObject
Dim SourceListObligos1 As Excel.ListObject
Dim SourceListObligos2 As Excel.ListObject
Dim SourceListObligos3 As Excel.ListObject
Dim SourceListBudget1 As Excel.ListObject
Dim SourceListBudget2 As Excel.ListObject
Dim SourceListBudget3 As Excel.ListObject
Dim TargetList As Excel.ListObject
Dim tmpStrNamePVListe As String
Dim tmpStrPfadPVListe As String
Dim tmpXlNewApp As Object
Dim tmpWbPVListe As Workbook
Dim tmpStr As String
'Application.ScreenUpdating = False
ThisWorkbook.Sheets("Maßnahmenkatalog").Unprotect Password:="Testpasswort"
tmpStrNamePVListe = ThisWorkbook.Sheets("Konstanten und Variablen").Range("E3").Value
tmpStrPfadPVListe = ThisWorkbook.Sheets("Konstanten und Variablen").Range("E5").Value & tmpStrNamePVListe & ".xlsx"
tmpStr = Dir(tmpStrPfadPVListe)
If Dir(tmpStrPfadPVListe) = "" Or ThisWorkbook.Sheets("Konstanten und Variablen").Range("B15").Value = "FALSCH" Then
GoTo Maßnahmenaktualisieren_abbruch
Else
On Error GoTo OpenError
Open tmpStrPfadPVListe For Binary Access Read Lock Read As #1
Close #1
On Error GoTo 0
Set tmpXlNewApp = CreateObject("Excel.Application")
Set tmpWbPVListe = tmpXlNewApp.Workbooks.Open(tmpStrPfadPVListe, ReadOnly:=True)
End If
On Error GoTo CopyError
If SheetExists(tmpWbPVListe, "Budgetübersicht") Then
Set SourceListBudgetplan1 = tmpWbPVListe.Sheets("Budgetübersicht").ListObjects("BudgetplanInst")
Set SourceListBudgetplan2 = tmpWbPVListe.Sheets("Budgetübersicht").ListObjects("BudgetplanInv")
Set SourceListBudgetplan3 = tmpWbPVListe.Sheets("Budgetübersicht").ListObjects("BudgetplanSond")
Else
Set SourceListBudgetplan1 = Nothing
Set SourceListBudgetplan2 = Nothing
Set SourceListBudgetplan3 = Nothing
End If
Set TargetList = ThisWorkbook.Sheets("Maßnahmenkatalog").ListObjects("Budgetplan")
If Not TargetList.DataBodyRange Is Nothing Then
TargetList.DataBodyRange.ClearContents
Else
TargetList.ListRows.Add
End If
If Not SourceListBudgetplan1 Is Nothing Then
If Not SourceListBudgetplan1.DataBodyRange Is Nothing Then
If Not SourceListBudgetplan1.DataBodyRange.Cells(1, 1) = "" Then
rowcountSource1 = SourceListBudgetplan1.DataBodyRange.Rows.Count
rowcountTarget = TargetList.DataBodyRange.Rows.Count
rowcountDifference = rowcountSource1 - rowcountTarget
TargetList.Resize Range(TargetList.Range.Resize(rowcountTarget + rowcountDifference + 1).Address)
If TargetList.DataBodyRange Is Nothing Then
TargetList.ListRows.Add
End If
SourceListBudgetplan1.DataBodyRange.Copy
TargetList.DataBodyRange.PasteSpecial Paste:=xlPasteValues
Else
rowcountSource1 = 0
End If
Else
rowcountSource1 = 0
End If
Else
rowcountSource1 = 0
End If
If Not SourceListBudgetplan2 Is Nothing Then
If Not SourceListBudgetplan2.DataBodyRange Is Nothing Then
If Not SourceListBudgetplan2.DataBodyRange.Cells(1, 1) = "" Then
rowcountSource2 = SourceListBudgetplan2.DataBodyRange.Rows.Count
rowcountTarget = TargetList.DataBodyRange.Rows.Count
rowcountDifference = rowcountSource1 + rowcountSource2 - rowcountTarget
TargetList.Resize Range(TargetList.Range.Resize(rowcountTarget + rowcountDifference + 1).Address)
If TargetList.DataBodyRange Is Nothing Then
TargetList.ListRows.Add
End If
SourceListBudgetplan2.DataBodyRange.Copy
TargetList.DataBodyRange.Offset(rowcountSource1, 0).Resize(TargetList.DataBodyRange.Rows.Count - rowcountSource1, TargetList.DataBodyRange.Columns.Count).PasteSpecial Paste:=xlPasteValues
Else
rowcountSource2 = 0
End If
Else
rowcountSource2 = 0
End If
Else
rowcountSource2 = 0
End If
If Not SourceListBudgetplan3 Is Nothing Then
If Not SourceListBudgetplan3.DataBodyRange Is Nothing Then
If Not SourceListBudgetplan3.DataBodyRange.Cells(1, 1) = "" Then
rowcountSource3 = SourceListBudgetplan3.DataBodyRange.Rows.Count
rowcountTarget = TargetList.DataBodyRange.Rows.Count
rowcountDifference = rowcountSource1 + rowcountSource2 + rowcountSource3 - rowcountTarget
TargetList.Resize Range(TargetList.Range.Resize(rowcountTarget + rowcountDifference + 1).Address)
If TargetList.DataBodyRange Is Nothing Then
TargetList.ListRows.Add
End If
SourceListBudgetplan3.DataBodyRange.Copy
TargetList.DataBodyRange.Offset(rowcountSource1 + rowcountSource2, 0).Resize(TargetList.DataBodyRange.Rows.Count - rowcountSource1 - rowcountSource2, TargetList.DataBodyRange.Columns.Count).PasteSpecial Paste:=xlPasteValues
Else
rowcountSource3 = 0
End If
Else
rowcountSource3 = 0
End If
Else
rowcountSource3 = 0
End If
If SheetExists(tmpWbPVListe, "Budgetübersicht") Then
Set SourceListObligos1 = tmpWbPVListe.Sheets("Budgetübersicht").ListObjects("ObligosInst")
Set SourceListObligos2 = tmpWbPVListe.Sheets("Budgetübersicht").ListObjects("ObligosInv")
Set SourceListObligos3 = tmpWbPVListe.Sheets("Budgetübersicht").ListObjects("ObligosSond")
Else
Set SourceListObligos1 = Nothing
Set SourceListObligos2 = Nothing
Set SourceListObligos3 = Nothing
End If
Set TargetList = ThisWorkbook.Sheets("Maßnahmenkatalog").ListObjects("Obligos")
If Not TargetList.DataBodyRange Is Nothing Then
TargetList.DataBodyRange.ClearContents
Else
TargetList.ListRows.Add
End If
If Not SourceListObligos1 Is Nothing Then
If Not SourceListBudgetplan1.DataBodyRange Is Nothing Then
If Not SourceListBudgetplan1.DataBodyRange.Cells(1, 1) = "" Then
rowcountSource1 = SourceListObligos1.DataBodyRange.Rows.Count
rowcountTarget = TargetList.DataBodyRange.Rows.Count
rowcountDifference = rowcountSource1 - rowcountTarget
TargetList.Resize Range(TargetList.Range.Resize(rowcountTarget + rowcountDifference + 1).Address)
If TargetList.DataBodyRange Is Nothing Then
TargetList.ListRows.Add
End If
SourceListObligos1.DataBodyRange.Copy
TargetList.DataBodyRange.PasteSpecial Paste:=xlPasteValues
Else
rowcountSource1 = 0
End If
Else
rowcountSource1 = 0
End If
Else
rowcountSource1 = 0
End If
If Not SourceListObligos2 Is Nothing Then
If Not SourceListBudgetplan2.DataBodyRange Is Nothing Then
If Not SourceListBudgetplan2.DataBodyRange.Cells(1, 1) = "" Then
rowcountSource2 = SourceListObligos2.DataBodyRange.Rows.Count
rowcountTarget = TargetList.DataBodyRange.Rows.Count
rowcountDifference = rowcountSource1 + rowcountSource2 - rowcountTarget
TargetList.Resize Range(TargetList.Range.Resize(rowcountTarget + rowcountDifference + 1).Address)
If TargetList.DataBodyRange Is Nothing Then
TargetList.ListRows.Add
End If
SourceListObligos2.DataBodyRange.Copy
TargetList.DataBodyRange.Offset(rowcountSource1, 0).Resize(TargetList.DataBodyRange.Rows.Count - rowcountSource1, TargetList.DataBodyRange.Columns.Count).PasteSpecial Paste:=xlPasteValues
Else
rowcountSource2 = 0
End If
Else
rowcountSource2 = 0
End If
Else
rowcountSource2 = 0
End If
If Not SourceListObligos3 Is Nothing Then
If Not SourceListBudgetplan3.DataBodyRange Is Nothing Then
If Not SourceListBudgetplan3.DataBodyRange.Cells(1, 1) = "" Then
rowcountSource3 = SourceListObligos3.DataBodyRange.Rows.Count
rowcountTarget = TargetList.DataBodyRange.Rows.Count
rowcountDifference = rowcountSource1 + rowcountSource2 + rowcountSource3 - rowcountTarget
TargetList.Resize Range(TargetList.Range.Resize(rowcountTarget + rowcountDifference + 1).Address)
If TargetList.DataBodyRange Is Nothing Then
TargetList.ListRows.Add
End If
SourceListObligos3.DataBodyRange.Copy
TargetList.DataBodyRange.Offset(rowcountSource1 + rowcountSource2, 0).Resize(TargetList.DataBodyRange.Rows.Count - rowcountSource1 - rowcountSource2, TargetList.DataBodyRange.Columns.Count).PasteSpecial Paste:=xlPasteValues
Else
rowcountSource3 = 0
End If
Else
rowcountSource3 = 0
End If
Else
rowcountSource3 = 0
End If
If SheetExists(tmpWbPVListe, "Budgetübersicht") Then
Set SourceListBudget1 = tmpWbPVListe.Sheets("Budgetübersicht").ListObjects("BudgetInst")
Set SourceListBudget2 = tmpWbPVListe.Sheets("Budgetübersicht").ListObjects("BudgetInv")
Set SourceListBudget3 = tmpWbPVListe.Sheets("Budgetübersicht").ListObjects("BudgetSond")
Else
Set SourceListBudget1 = Nothing
Set SourceListBudget2 = Nothing
Set SourceListBudget3 = Nothing
End If
Set TargetList = ThisWorkbook.Sheets("Maßnahmenkatalog").ListObjects("Budget")
If Not TargetList.DataBodyRange Is Nothing Then
TargetList.DataBodyRange.ClearContents
Else
TargetList.ListRows.Add
End If
If Not SourceListBudget1 Is Nothing Then
If Not SourceListBudgetplan1.DataBodyRange Is Nothing Then
If Not SourceListBudgetplan1.DataBodyRange.Cells(1, 1).Value = "" Then
rowcountSource1 = SourceListBudget1.DataBodyRange.Rows.Count
rowcountTarget = TargetList.DataBodyRange.Rows.Count
rowcountDifference = rowcountSource1 - rowcountTarget
TargetList.Resize Range(TargetList.Range.Resize(rowcountTarget + rowcountDifference + 1).Address)
If TargetList.DataBodyRange Is Nothing Then
TargetList.ListRows.Add
End If
SourceListBudget1.DataBodyRange.Copy
TargetList.DataBodyRange.PasteSpecial Paste:=xlPasteValues
Else
rowcountSource1 = 0
End If
Else
rowcountSource1 = 0
End If
Else
rowcountSource1 = 0
End If
If Not SourceListBudget2 Is Nothing Then
If Not SourceListBudgetplan2.DataBodyRange Is Nothing Then
If Not SourceListBudgetplan2.DataBodyRange.Cells(1, 1) = "" Then
rowcountSource2 = SourceListBudget2.DataBodyRange.Rows.Count
rowcountTarget = TargetList.DataBodyRange.Rows.Count
rowcountDifference = rowcountSource1 + rowcountSource2 - rowcountTarget
TargetList.Resize Range(TargetList.Range.Resize(rowcountTarget + rowcountDifference + 1).Address)
If TargetList.DataBodyRange Is Nothing Then
TargetList.ListRows.Add
End If
SourceListBudget2.DataBodyRange.Copy
TargetList.DataBodyRange.Offset(rowcountSource1, 0).Resize(TargetList.DataBodyRange.Rows.Count - rowcountSource1, TargetList.DataBodyRange.Columns.Count).PasteSpecial Paste:=xlPasteValues
Else
rowcountSource2 = 0
End If
Else
rowcountSource2 = 0
End If
Else
rowcountSource2 = 0
End If
If Not SourceListBudget3 Is Nothing Then
If Not SourceListBudgetplan3.DataBodyRange Is Nothing Then
If Not SourceListBudgetplan3.DataBodyRange.Cells(1, 1) = "" Then
rowcountSource3 = SourceListBudget3.DataBodyRange.Rows.Count
rowcountTarget = TargetList.DataBodyRange.Rows.Count
rowcountDifference = rowcountSource1 + rowcountSource2 + rowcountSource3 - rowcountTarget
TargetList.Resize Range(TargetList.Range.Resize(rowcountTarget + rowcountDifference + 1).Address)
If TargetList.DataBodyRange Is Nothing Then
TargetList.ListRows.Add
End If
SourceListBudget3.DataBodyRange.Copy
TargetList.DataBodyRange.Offset(rowcountSource1 + rowcountSource2, 0).Resize(TargetList.DataBodyRange.Rows.Count - rowcountSource1 - rowcountSource2, TargetList.DataBodyRange.Columns.Count).PasteSpecial Paste:=xlPasteValues
Else
rowcountSource3 = 0
End If
Else
rowcountSource3 = 0
End If
Else
rowcountSource3 = 0
End If
On Error GoTo 0
tmpWbPVListe.Close SaveChanges:=False
Set tmpXlNewApp = Nothing
ThisWorkbook.Sheets("Prüfvermerk").Activate
ThisWorkbook.Sheets("Prüfvermerk").Range("F4").Select
ThisWorkbook.Sheets("Maßnahmenkatalog").Protect Password:="Testpasswort", UserInterfaceOnly:=True
Application.ScreenUpdating = True
Exit Sub
CopyError:
MsgBox ("Fehler Nummer " & Err.Number & " durch Objekt " & Err.Source & " ausgelöst: " & Err.Description)
tmpWbPVListe.Close SaveChanges:=False
Set tmpXlNewApp = Nothing
ThisWorkbook.Sheets("Prüfvermerk").Activate
ThisWorkbook.Sheets("Prüfvermerk").Range("F4").Select
ThisWorkbook.Sheets("Maßnahmenkatalog").Protect Password:="Testpasswort", UserInterfaceOnly:=True
Application.ScreenUpdating = True
Exit Sub
OpenError:
ThisWorkbook.Sheets("Prüfvermerk").Range("F4").Select
ThisWorkbook.Sheets("Maßnahmenkatalog").Protect Password:="Testpasswort", UserInterfaceOnly:=True
Application.ScreenUpdating = True
Exit Sub
Maßnahmenaktualisieren_abbruch:
ThisWorkbook.Sheets("Prüfvermerk").Range("F4").Select
ThisWorkbook.Sheets("Maßnahmenkatalog").Protect Password:="Testpasswort", UserInterfaceOnly:=True
Application.ScreenUpdating = True
Exit Sub
End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hi Daniel,
danke für die Antwort.
Problem hierbei ist, dass Excel ohne Error Abfrage im Code nur den generischen Fehler 1004 Text ausgibt ohne Hinweis im Text was genau fehl schlägt. Und da die Subroutine Aus der Workbook_Open() Routine heraus aufgerufen wird, zeigt der Debugger im Code in dem Fall nur auf den Aufruf meiner Subroutine und nicht auf die Stelle in der Subroutine selbst.
Das Ergebnis in der Excel Datei ist dabei "fast" das gleiche wie im von mir hier gezeigten Fall. Der Bereich in den eingefügt werden muss ist selektiert und passt größenmäßig. Die Daten sind immer korrekt im Zwischenspeicher und ich kann sie von Hand wunderbar einfügen.
Setze ich von Hand Haltepunkte in der Subroutine und gehe step by step durch, schlägt das ganze übrigens nie fehl.
Was ich Eingangs noch vergaß: Der Aufmerksame Leser wird es auch gesehen haben: Ich habe das ganze zuvor mal im Hintergrund laufen lassen und mit Application.ScreenUpdating = True, versteckt. Seit diese Zeile auskommentiert ist tritt das Problem weniger häufig aber leider nach wie vor auf.

Beliebteste Forumthreads (12 Monate)

PasteSpecial schlägt sporadisch fehl

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread