PasteSpecial schlägt sporadisch fehl
11.08.2022 11:31:57
Chrithu
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