Bestimmte Zeilen in anderes Tabellenblatt kopieren- VBA

[Timotee]

Liebe Community
ich habe folgendes Anliegen und habe bereits mehrere Tutorials durchgeschaut. Doch leider klappt es immernoch nicht.
Ich hab 3 Tabellenblätter und möchte eine ganze Zeile in ein neues Tabellenblatt ( WEEKLY DISCUSSION) kopieren, wenn eine bestimmte Bedingung (Criteria) erfüllt ist.
Nun hab ich mit Macros gearbeitet und folgenden Code erstellt.
Zunächst wurde nur die Information aus einem Tabellenblatt angezeigt, obwohl mein Code alle 3 Tabellenblätter anzeigt. Dann habe ich gedacht, dass ich ja die letzte Zeile nicht immer als A1 bezeichnen kann, weil die Informationen immer überschreiben werden. So hab ich "
CopyToRange" im Code umgeschrieben
. Bei nochmaligem updaten kann dann aber eine Fehlermeldung und es wurde nichts mehr angezeigt.
Was ist an meinem Code falsch?
Wie bekomme ich bestimmte Zeilen aus mehreren Tabellenblättern in eine neue Übersichtstabelle? Alle Tabellenblätter sind in einer Excel-Datei (Macro-Enabled Template).
Ich wäre sehr froh, wenn hier jemand helfen kann.
Herzlichen Dank im Vorfeld.
Timotee

Code:

Sub Filter_TeamUpdate()
'
' Filter_TeamUpdate Macro
' Timotee
'
lngLastRowANNA = Sheets("ANNA").Cells(Rows.Count, 1).End(x1Up).Row
lngLastRowJULIA = Sheets("JULIA").Cells(Rows.Count, 1).End(x1Up).Row
lngLastRowANDREA = Sheets("ANDREA").Cells(Rows.Count, 1).End(x1Up).Row
lngLastRow = ActiveSheet.UsedRage.Row(ActiveSheet.UsedRage.Rows.Count).Row
Sheets("WEEKLY DISCUSSION").Select
Sheets("ANNA").Range("A1:H" & lngLastRowANNA).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("CRITERIAS").Range("A2:H" & lngLastRowANNA),
CopyToRange:=Range("A1")
_
, Unique:=False
lngLastRow = Sheets("WEEKLY DISCUSSION").Cells(Rows.Count, 1).End(x1Up).Row
Sheets("JULIA").Range("A1:H" & lngLastRowJULIA).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("CRITERIAS").Range("A2:H" & lngLastRowJULIA),
CopyToRange:=Range("A" & lngLastRow + 1)
_
, Unique:=False
lngLastRow = Sheets("WEEKLY DISCUSSION").Cells(Rows.Count, 1).End(x1Up).Row
Sheets("ANDREA").Range("A1:H" & lngLastRowANDREA).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("CRITERIAS").Range("A2:H" & lngLastRowANDREA),
CopyToRange:=Range("A" & lngLastRow + 1)
_
, Unique:=False
lngLastRow = Sheets("WEEKLY DISCUSSION").Cells(Rows.Count, 1).End(x1Up).Row
End Sub

[Niko]

Bin auch ein Anfänger, aber vielleicht hilft Ihnen dieser Link weiter in Ihren Vorhaben.

Office: Vba Wenn Bedingung erfüllt kopiere in ein anders Tabellenblatt


Danke,

Niko

[Gast 123]

Hallo Timotee

Sorry, wie schafft man es in eine einfache Text Nachricht den ganzen Quatsch mit der Schriftart Einstellung reinzupacken?
Das war mir zu aufwendig das alles im Gehirn zu entflechten.  Vielleicht hilft dir die Antwort des Kollegen mit dem Link ja weiter.
Sonst wäre es sinnvoller eine Beispieldatei hochzuladen, mit kurzen Erläuterungen wie die Lösung aussehen soll.

mfg Gast 123

[schauan]

Hallöchen,

ja, das mit den Formatierungen passiert ab und zu, das ist vom Ersteller nicht beabsichtigt.
Ich hab den Beitrag mal editiert.

[Gast 123]

---

Hallo

ich habe noch nie mit einem Unique Code gearbeitet und kann ihn nicht testen. Probiere bei fremden Codes einfach mal aus ob ich sie ans laufen bekomme.
Das ist einfach mal ein Verswuch zu helfen, ohne zu wissen ob das so klappt???  Wenn der obere Teil nicht klappt mal die unter Alternative ausprobieren.
 Ist nur ein Schnippsel!

mfg Gast 123

Code:

Sub Filter_TeamUpdate()
Dim WD As Worksheet
' Filter_TeamUpdate Macro
' Timotee
lngLastRowANNA = Sheets("ANNA").Cells(Rows.Count, 1).End(x1Up).Row
lngLastRowJULIA = Sheets("JULIA").Cells(Rows.Count, 1).End(x1Up).Row
lngLastRowANDREA = Sheets("ANDREA").Cells(Rows.Count, 1).End(x1Up).Row
Sheets("WEEKLY DISCUSSION").Select
Set WD = Sheets("WEEKLY DISCUSSION")

lngLastRow = WD.Cells(Rows.Count, 1).End(x1Up).Row + 1  '** benötight???
Sheets("ANNA").Range("A1:H" & lngLastRowANNA).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("CRITERIAS").Range("A2:H" & lngLastRowANNA), _
CopyToRange:=WD.Range("A1"), Unique:=False

lngLastRow = WD.Cells(Rows.Count, 1).End(x1Up).Row + 1
Sheets("JULIA").Range("A1:H" & lngLastRowJULIA).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("CRITERIAS").Range("A2:H" & lngLastRowJULIA), _
CopyToRange:=WD.Range("A" & lngLastRow), Unique:=False

lngLastRow = WD.Cells(Rows.Count, 1).End(x1Up).Row + 1
Sheets("ANDREA").Range("A1:H" & lngLastRowANDREA).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("CRITERIAS").Range("A2:H" & lngLastRowANDREA), _
CopyToRange:=WD.Range("A" & lngLastRow), Unique:=False

lngLastRow = Sheets("WEEKLY DISCUSSION").Cells(Rows.Count, 1).End(x1Up).Row
End Sub



Sub Alternative()
lngLastRow = WD.Cells(Rows.Count, 1).End(x1Up).Row + 1  '** benötight???
Sheets("ANNA").Range("A1:H" & lngLastRowANNA).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("CRITERIAS").Range("A2:H" & lngLastRowANNA).Copy, Unique:=False
WD.Range("A1").PasteSpecial xlPasteAll
End Sub