Makro: Zeilen löschen, kopieren, filtern

Hallo an euch alle,
habe mir unten stehendes Makro aufgezeichnet und möchte euch nun bitten, dies so abzuändern, dass es jederzeit wiederholbar ist.
Beim Starten des Makros ist die Tabelle nach dem Text in A1 gefiltert und einige der eingeblendeten Zeilen haben rote Schriftfarbe und einige schwarze Schriftfarbe.
Was nun eigentlich passieren soll,
1. sollen alle eingeblendeten, schwarz geschriebenen Zeilen gelöscht werden. (in meinem Beispiel kamen diese Zeilen aus dem Bereich 3770:57183)
2. Wenn der Filter nicht bereits entfernt wurde, weil Zeile 1 gelöscht wurde, soll der Filter entfernt werden.
3. Die Tabelle soll nach F absteigend, C aufsteigend sortiert werden (ich weiß das fehlt bei der Aufzeichnung)
4. alle am Anfang der Tabelle rot geschriebenen Zeilen sollen ans Ende der Tabelle namens Ergebnis kopiert werden. In meinem Beispiel wurden die Zeilen 1 und 2 weil sie rot geschrieben waren ans Ende der Tabelle Ergebnis kopiert, in die Zeilen 2062 und 2063. Alles was nach der ersten schwarzen Zeile kommt soll nicht kopiert werden, auch wenn es rote Schriftfarbe hat.
5. Danach habe ich die zuvor kopierten Zeilen gelöscht.
6. und die Mappe wieder nach dem Text in A1, in diesem Fall tt3671676 gefiltert.
Ihr merkt da ist vieles dabei, was sich bei jedem Ausführen des Makros ändert, daher bitte ich euch um Hilfe.
Gruß und dank
Christian

Sub Makro1()
' Makro1 Makro
' Tastenkombination: Strg+j
Rows("3770:57183").Select
Selection.Delete Shift:=xlUp
ActiveSheet.ShowAllData
Rows("1:2").Select
Selection.Cut
Sheets("Ergebnis").Select
Range("A2062").Select
ActiveSheet.Paste
ActiveWindow.SmallScroll Down:=6
Sheets("Auswertung").Select
Selection.Delete Shift:=xlUp
Range("A1").Select
Selection.Copy
Application.CutCopyMode = False
Selection.AutoFilter
Selection.Copy
ActiveSheet.Range("$A$1:$F$59449").AutoFilter Field:=1, Criteria1:= _
"tt3671676"
End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Rob, ich versuche zur Zeit mein Bestes, aber das ist sehr schwer da was zusammenzubringen da ich eine im Original 43,2 MB große Tabelle auf 300 KB kürzen muss und sie immer noch alle eventualitäten beinhalten soll.
Aber auf weniger als 640 KB schaffe ich sie im Moment nicht zu bringen, ohne dass es unverständlich wird.
Ich versuche es mal nochmal einfacher zu erklären was es machen soll, vielleicht bekommt man es ja auch ohne Beispiel hin.
1. Alle Zu beginn eingeblendeten und schwarz geschriebenen Zeilen löschen. (Kann in Ausnahmefällen auch sein dass keine eingeblendete Zeile schwarz geschrieben ist, dann soll halt nichts gelöscht werden).
2. den Filter in Spalte A entfernen falls er noch gesetzt ist.
3. die Tabelle nach Spalte F absteigend, dann Spalte C aufsteigend sortieren.
4. Falls die jetzige Zelle A1 schwarz geschrieben ist, kann das Makro an dieser Stelle beendet werden, wenn sie rot geschrieben ist geht es weiter:
5. alle rot geschriebenen Zeilen zu Beginn der Tabelle sollen ans Ende der Tabelle namens Ergebnis kopiert werden.
Beispiel: in der Tabelle Auswertung, um die es geht, ist Zeile 1 und 2 rot geschrieben und Zeile 3 schwarz geschrieben, also sollen die beiden ersten Zeilen, da sie rot geschrieben sind ans Ende der Tabelle Ergebnis kopiert werden. Und zwar in die Zeilen 2079 und 2080 da die Tabelle Ergebnis bislang aus 2078 Zeilen besteht.
6. alle soeben kopierten Zeilen sollen in der Tabelle Auswertung gelöscht werden, sodass Auswertung!A1 auf jeden Fall schwarz geschriebenen Text enthält.
7. Der Filter soll wieder in Spalte A gesetzt werden, als Kriterium der Text in A1.
Ist das jetzt irgendwie verständlicher?
Gruß
Christian

Option Explicit Sub Christian() Dim r As Range Dim LastRow As Long Dim Filterkriterium As String Filterkriterium = Tabelle1.Range("A1") 'tt0463834 LastRow = Tabelle1.Cells(Rows.Count, 1).End(xlUp).Row With Tabelle1 For Each r In .Range("A1:A" & LastRow) If r = Filterkriterium And r.Font.Color = RGB(0, 0, 0) Then r.EntireRow.Delete End If Next r 'Nach F aufsteigend, nach C absteigend .Sort.SortFields.Clear .Sort.SortFields.Add Key:= _ Range("F1:F" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _ :=xlSortNormal With .Sort .SetRange Range("A1:F" & LastRow) .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With .Sort.SortFields.Clear .Sort.SortFields.Add Key:= _ Range("C1:C" & LastRow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _ xlSortNormal With .Sort .SetRange Range("A1:F" & LastRow) .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With 'Zellen bis zur ersten font color schwarz in Tabelle2, Spalte1 Ende kopieren For Each r In .Range("A:A") If r.Font.Color = RGB(255, 0, 0) Then LastRow = Tabelle2.Cells(Rows.Count, 1).End(xlUp).Row + 1 Sheets("Ergebnis zu Beginn").Cells(LastRow, 1) = r Else GoTo ZellenLöschen End If Next r 'Kopierte Zellen aus Tabelle1 löschen ZellenLöschen: .Range("A1").Activate Do While ActiveCell.Font.Color = RGB(255, 0, 0) Tabelle1.Range("A1").Activate If ActiveCell.Font.Color = RGB(255, 0, 0) Then ActiveCell.EntireRow.Delete End If Loop End With End Sub

Beliebteste Forumthreads (12 Monate)

Makro: Zeilen löschen, kopieren, filtern

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

315 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Makro: Zeilen löschen, kopieren, filtern

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

315 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread