1004 - bei Kopieren funktionierenden Befehls

Hallo ihr Lieben!
Ich wäre super dankbar für eure Hilfe. Ich hab einen funktionierenden Befehl geschrieben um 14 Datenblätter mit 2 Kriterien auf ein weiteres Datenblatt zu kopieren (nämlich wenn die Kriterien "A" und "offen". Wenn ich drei Datenblätter mit jeweiligem Namen einfüge, funktioniert alles gut. Sobald ich das 4. copy/paste kommt die Fehlermeldung 1004. Ich habe auch die vierte mal mit der dritten ersetzt und auch das hat funktioniert. Es kommt also der Eindruck auf, das "ein weiteres" Datenblatt zu viel ist. Fehler beim Kopieren können eig kaum aufgekommen sein, da ich nur 5 Buchstaben ändern musste. Wäre euch sehrsehr dankbar für Hilfe !
Danke, Lui
Hier mal noch der code:


Sub Mehrere_Listen_Filtern()
' Mehrere_Listen_Filtern Makro
lngLastRowBAR = Sheets("Name1").Cells(Rows.Count, 1).End(xlUp).Row
lngLastRowDAN = Sheets("Name2").Cells(Rows.Count, 1).End(xlUp).Row
lngLastRowFAS = Sheets("Name3").Cells(Rows.Count, 1).End(xlUp).Row
lngLastRowFRI = Sheets("Name4").Cells(Rows.Count, 1).End(xlUp).Row
lngLastRowKR = Sheets("Kriterien").Cells(Rows.Count, 1).End(xlUp).Row
lngLastRow = Sheets("Ueberblick_Aufgaben").Cells(Rows.Count, 1).End(xlUp).Row
Sheets("Ueberblick_Aufgaben").Select
Range("A1").Select
Sheets("Name1").Range("A1:F" & lngLastRowBAR).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Kriterien").Range("A1:F2"), CopyToRange:=Range("A1") _
, Unique:=False
lngLastRow = Sheets("Ueberblick_Aufgaben").Cells(Rows.Count, 1).End(xlUp).Row
Sheets("Name2").Range("A1:F" & lngLastRowDAN).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Kriterien").Range("A1:F2"), CopyToRange:=Range("A" & lngLastRow + _
_
_
1) _
, Unique:=False
lngLastRow = Sheets("Ueberblick_Aufgaben").Cells(Rows.Count, 1).End(xlUp).Row
Sheets("Name3").Range("A1:F" & lngLastRowFAS).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Kriterien").Range("A1:F2"), CopyToRange:=Range("A" & lngLastRow + _
_
_
1) _
, Unique:=False
lngLastRow = Sheets("Ueberblick_Aufgaben").Cells(Rows.Count, 1).End(xlUp).Row
Sheets("Name4").Range("A1:F" & lngLastRowFRI).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Kriterien").Range("A1:F2"), CopyToRange:=Range("A" & lngLastRow + _
_
_
1) _
, Unique:=False
End Sub

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

Sub Mehrere_Listen_Filtern_neu() ' Mehrere_Listen_Filtern Makro Dim lngLastrow As Long, iBlatt As Integer Dim lngLastRowBlatt As Long Sheets("Ueberblick_Aufgaben").Select Range("A1").Select For iBlatt = 1 To ActiveWorkbook.Worksheets.Count Select Case ActiveWorkbook.Worksheets(iBlatt).Name Case "Ueberblick_Aufgaben", "Kriterien" 'diese Blätter nicht filtern und kopieren Case Else lngLastrow = Sheets("Ueberblick_Aufgaben").Cells(Rows.Count, 1).End(xlUp).Row If lngLastrow = 1 Then lngLastrow = 0 'Einfügen ab A1 wenn Blatt leer lngLastRowBlatt = Worksheets(iBlatt).Cells(Rows.Count, 1).End(xlUp).Row Worksheets(iBlatt).Range("A1:F" & lngLastRowBlatt).AdvancedFilter _ Action:=xlFilterCopy, _ CriteriaRange:=Sheets("Kriterien").Range("A1:F2"), _ CopyToRange:=Range("A" & lngLastrow + 1), Unique:=False ' If lngLastrow > 1 Then Rows(lngLastrow + 1).Delete 'Spaltentitel löschen End Select Next End Sub

Beliebteste Forumthreads (12 Monate)

1004 - bei Kopieren funktionierenden Befehls

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread