Schnelle Unterstützung bei Excel-Makro

Hallo,
wie geht es euch? Kann mir jemand helfen?


1. Eine Tabelle A bis D und mehere Textzeilen 1 bis 20. Ich benötige ein Makro, was die Tabelle 1 in jeder Zeile nach einem Begriff "A" der in der Spalte D vorhanden ist,
durchsucht und wenn die letzte leere Zelle erreicht wurde nach einem 2. Begriff "B" und 3. Begriff "C" wieder Zeile für Zeile durchsucht. Dabei sollen alle "A" und
alle "B" aus Tabelle 1 (gesamte Zeile) in Tabelle 2 kopiert werden. Sortiert nach A und B. Alle Begriffe "C" in Tabelle 3 kopiert werden.


2. Die Tabelle 2 sollen dann nach bestimmten Begriffen "*Test1*" und "*Test2*" Zeile für Zeile durchsucht und gelöscht werden.


Ich hoffe, dass die Beschreibung einigermaßen verständlich geschrieben ist.


Vielen Dank im Voraus . . .


Hallo,
wie geht es euch? Kann mir jemand helfen?

Hier die Daten . . .

Tabelle1
A B C D
1 Büro 3631 fuermichseite
2 Aktuelles 2574 fuermichseite1
3 Bank 2366 fuermichseite
4 Haus 1795 fuermichseite1
5 Schrank 1156 fuermichseite1
6 Aktuelles 1140 fuermichseite
7 Test 677 fuermichseite2
8 Test 611 fuermichseite2
9 Test 594 fuermichseite3


Ergebnis Tabelle2
A B C
Büro 3631 fuermichseite
Bank 2366 fuermichseite
Aktuelles 1140 fuermichseite
Aktuelles 2574 fuermichseite1
Haus 1795 fuermichseite1
Schrank 1156 fuermichseite1


Und hier die Beschreibung . . .

Suche aus der Tabelle1 alle Begriffe "*seite" und kopiere diese Zeilen ohne Spalte A in die 2. Tabelle.
Wenn alle Begriffe "seite" kopiert wurden dann suche nach dem Begriff "*seite1"
und kopiere diese auch in die 2. Tabelle in die erste freie Zeile nach dem Begriff "seite".


Vielen Dank für die Unterstützung!!!

Option Explicit
Option Compare Text

Const Sheet1 = "Tabelle1"   'Tabellenname Tabelle 1  
Const Sheet2 = "Tabelle2"   'Tabellenname Tabelle 2  

Const TitelZeile = 2        'Überschriftzeile  
Const StartZeile = 3        'Daten ab Zeile ?  

Sub KopierenUndSortieren()
    Dim Suchbegriffe, Wks1 As Worksheet, Wks2 As Worksheet, c As Range, AktuelleZeile As Long, i As Integer
    
    Suchbegriffe = Array("AQ", "TE", "GR")  
    
    Set Wks1 = Sheets(Sheet1):  Set Wks2 = Sheets(Sheet2)
    
    AktuelleZeile = StartZeile
    
    Wks2.Cells.Clear
       
    With Wks1
        For Each c In .Range("D:D")  
            For i = 0 To UBound(Suchbegriffe)
                If c Like Suchbegriffe(i) Then
                    Range(.Cells(c.Row, "B"), .Cells(c.Row, "D")).Copy Wks2.Cells(AktuelleZeile, "A")  
                    AktuelleZeile = AktuelleZeile + 1:  Exit For
                End If
            Next
        Next
    End With
    
    With Wks2
       .Cells(StartZeile, "A").CurrentRegion.Sort _  
            Key1:=.Cells(StartZeile, "C"), Key2:=.Cells(StartZeile, "A"), Key3:=.Cells(StartZeile, "B")  
        Range(Wks1.Cells(TitelZeile, "B"), Wks1.Cells(TitelZeile, "D")).Copy .Cells(TitelZeile, "A")  
    End With
End Sub

Sub SuchenUndLoeschen()
    Dim Suchbegriffe, EndLine As Long, i As Long, a As Integer
    
    Suchbegriffe = Array("AQ", "TE")  
    
    With Sheets(Sheet2)
        EndLine = .Cells(.Rows.Count, "C").End(xlUp).Row  
        
        For i = StartZeile To EndLine
            If i > EndLine Then Exit For
            For a = 0 To UBound(Suchbegriffe)
                If .Cells(i, "C") Like Suchbegriffe(a) Then  
                   .Rows(i).Delete:  i = i - 1:  EndLine = EndLine - 1:  Exit For
                End If
            Next
        Next
    End With
End Sub