Vba Alle Tabellenblätter durchsuchen und wenn Kriterium erfüllt in ein neues Tabellenblatt...

Hallo Claus,

ausprobiert habe ich das Makro mit ein Test Tabelle.

Funktioniert gut.

Bei meiner Original Tabelle kopiert das Makro zwar die Zeilen die mit x markiert sind allerdings nicht mit meinen

Formatierungen und Formeln.

Das Makro zeigt mir immer in der Zeile .Range einen Fehler an (Laufzeitfehler: 1004)

Sorry Ich bin nicht so Fit in VBA

'In den nächsten Zeilen den Tabellenbereich anpassen

.Range("A1:Z" & LRow).AutoFilter field:=24, Criteria1:="x"

If Application.Subtotal(3, .Range("A:A")) > 1 Then

Ist das vielleicht auch ein Problem wenn ich die beiden ersten Zeilen in meiner Original Tabelle fixiert hab?

Lg

Christian

Hallo Claus,

ich danke dir für die schnelle Antwort.

Dein Makro funktioniert super

Lg

Christian

Hallo Christian,

wenn du den Bereich anpassen willst, musst du das bei .Range("A1:Z" & LRow) machen. Also das Z gegen deine letzte Spalte tauschen.

Wenn du das "x" in Spalte W suchst, muss Field:=23 bleiben.

Das Fixieren hat keinen Einfluss auf das Kopieren.

Um auch die Formel zu kopieren, ändere den Code:

Sub Uebertrag()Dim i As IntegerDim LRow As LongFor i = 2 To Sheets.Count With Sheets(i) LRow = .Cells(.Rows.Count, 1).End(xlUp).Row 'In den nächsten Zeilen den Tabellenbereich anpassen .Range("A1:Z" & LRow).AutoFilter field:=23, Criteria1:="x" If Application.Subtotal(3, .Range("A:A")) > 1 Then .Range("A2:Z" & LRow).Copy Sheets(1).Cells(Rows.Count, 1).End(xlUp)(2).PasteSpecial xlPasteAll End If .AutoFilterMode = False End WithNextEnd Sub
Sollte dies nicht helfen, stelle deine Mappe zur Verfügung (Hochladen und hier den Link zur Mappe posten).

Claus

Hallo Christian,

falls in einem Tabellenblatt kein "x" vorkommen sollte, probiere es besser so:

Sub Uebertrag()Dim i As IntegerDim LRow As LongFor i = 2 To Sheets.Count With Sheets(i) LRow = .Cells(.Rows.Count, 1).End(xlUp).Row 'In den nächsten Zeilen den Tabellenbereich anpassen .Range("A1:Z" & LRow).AutoFilter field:=23, Criteria1:="x" If Application.Subtotal(3, .Range("A:A")) > 1 Then .Range("A2:Z" & LRow).Copy Sheets(1).Cells(Rows.Count, 1).End(xlUp)(2) End If .AutoFilterMode = False End WithNextEnd Sub

Claus

Hallo Christian,

das geht schneller, wenn du in Spalte W nach "x" filterst und dann die gefilterte Liste überträgst.

Probiere es mal so:

Sub Uebertrag()Dim i As IntegerDim LRow As LongFor i = 2 To Sheets.Count With Sheets(i) LRow = .Cells(.Rows.Count, 1).End(xlUp).Row 'In den nächsten 2 Zeilen den Tabellenbereich anpassen .Range("A1:Z" & LRow).AutoFilter field:=23, Criteria1:="x" .Range("A2:Z" & LRow).Copy Sheets(1).Cells(Rows.Count, 1).End(xlUp)(2) .AutoFilterMode = False End WithNextEnd Sub

Claus