Kombinierte Suche in Excel mit mehreren Treffern

Const SheetName = "Tabelle1"        ' Tabellennamen  
Const Suchbereich = "A:C"           ' Suchbereich in den Spalten A-C oder in der Art "A:A"  

Sub Test()
    Dim Suchliste As Variant, Token As Variant, Eingabe As String, Ergebnisliste As String
    
    Eingabe = InputBox("Bitte Suchbegriffe Komma-Getrennt eingeben:", "Suchen...")  
    
    If Eingabe = "" Then Exit Sub  
    
    Suchliste = Split(Eingabe, ",")  
    
    For Each Token In Suchliste
        If Token <> "" Then  
            Call Search(Sheets(SheetName).Range(Suchbereich), Trim(Token), Ergebnisliste)
        End If
    Next
    
    If Ergebnisliste = "" Then  
        MsgBox "Keine Übereinstimmung gefunden!", vbInformation, "Suchergebnis..."  
    Else
        MsgBox Ergebnisliste, , "Suchergebnis..."  
    End If
End Sub

Private Sub Search(ByRef Area, ByRef Token, ByRef List)
    Dim Found As Range, FirstAddress As String
    
    Set Found = Area.Find(Token, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
    
    If Not Found Is Nothing Then
        FirstAddress = Found.Address
        Do
            List = List & Token & vbTab & Found.Address & vbCr
            Set Found = Area.FindNext(Found)
        Loop While Not Found Is Nothing And Found.Address <> FirstAddress
    End If
End Sub

Sub Suchen()
Suche = "Haftnotiz Post-It Klebezettel"  

QuellTabelle = "Daten"  
QuellZeile = 2
SuchSpalte = 2 'B  
QuellSpalteVon = 1 'A  
QuellSpalteBis = 4 'D  

ZielTabelle = "Ergebnis"  
ZielZeile = 2
ZielSpalte = "A"  

With Worksheets(QuellTabelle)
    Wert = .Cells(QuellZeile, SuchSpalte).Value
    Do While Wert <> ""  
        If InStr(1, Suche, Wert, vbTextCompare) > 0 Then
            Worksheets(ZielTabelle).Cells(ZielZeile, ZielSpalte).Resize(1, QuellSpalteBis - QuellSpalteVon + 1).Value = .Range(.Cells(QuellZeile, QuellSpalteVon), .Cells(QuellZeile, QuellSpalteBis)).Value
            ZielZeile = ZielZeile + 1
        End If
        QuellZeile = QuellZeile + 1
        Wert = .Cells(QuellZeile, SuchSpalte).Value
    Loop
End With
End Sub

Sub Suchen()
Suche = "Haftnotiz,Post-It,Klebezettel"  
Delim = "," 'Trennzeichen zwischen Suchbegriffen  

QuellTabelle = "Daten"  
QuellZeile = 2
SuchSpalte = "B"  
QuellSpalteVon = "A"  
QuellSpalteBis = "D"  

ZielTabelle = "Ergebnis"  
ZielZeile = 2
ZielSpalte = "A"  

Such = Split(Suche, Delim) 'Suchbegriffe in Array aufteilen  
SuchAnz = UBound(Such) 'höchsten Index des Such-Arrays vor der Schleife (und damit nur einmal) ermitteln  

With Worksheets(QuellTabelle)
    Wert = .Cells(QuellZeile, SuchSpalte).Value
    Do While Wert <> ""  
        For i = 0 To SuchAnz
            If InStr(1, Wert, Such(i), vbTextCompare) > 0 Then
                Worksheets(ZielTabelle).Cells(ZielZeile, ZielSpalte).Resize(1, 4).Value = .Range(.Cells(QuellZeile, QuellSpalteVon), .Cells(QuellZeile, QuellSpalteBis)).Value
                ZielZeile = ZielZeile + 1
                Exit For 'Suchbegriff enthalten, weitere Vergleiche für diesen Wert unnötig  
            End If
        Next
        QuellZeile = QuellZeile + 1
        Wert = .Cells(QuellZeile, SuchSpalte).Value
    Loop
End With
End Sub

Const FilterSheet = "Tabelle1"  
Const FilterAuswahl = "Haftnotiz, Post-It, Klebezettel"  

Private Sub Workbook_Open()
    Dim Kriterien As Variant, Token As Variant
    
    Kriterien = Split("Filter Aus," & FilterAuswahl, ",")  
    
    With Sheets(FilterSheet).ComboBox1
       .Clear
        For Each Token In Kriterien
            If Not Token = "" Then .AddItem Trim(Token)  
        Next
       .ListIndex = 0
    End With
End Sub

Const FilterRange = "B:B"   'Spalte mit Filterbegriffen  

Private Sub ComboBox1_Change()
    Dim Suchtext As String
    
    If ComboBox1.Text = "Filter Aus" Then  
        ActiveSheet.AutoFilterMode = False
    Else
        Suchtext = "*" & ComboBox1.Text & "*"  'Teilübereinstimmung vor und nach mit "*"  
        Range(FilterRange).AutoFilter Field:=1, Criteria1:=Suchtext, VisibleDropDown:=False
    End If
End Sub

Const SheetQuelle = "Daten"         ' Tabelle Daten/Suchen  
Const SheetZiel = "Vergleich"       ' Tabelle Suchergebnis  

Const SpalteSuchen = "C:C"          ' Spalte Suchen  
Const DatenSpalteVon = "A"          ' Daten kopieren von Spalte  
Const DatenSpalteBis = "F"          ' Daten kopieren bis Spalte  

Const ZielSpalte = "A"              ' Spalte Ziel-Tabelle  

Sub Suchen()
    Dim WksQ As Worksheet, WksZ As Worksheet, Suchliste As Variant, Token As Variant, Eingabe As String
    
    Eingabe = InputBox("Bitte Suchbegriffe Komma-Getrennt eingeben:", "Suchliste...")  
    
    If Eingabe = "" Then Exit Sub  
    
    Set WksQ = Sheets(SheetQuelle)
    Set WksZ = Sheets(SheetZiel):  WksZ.Cells.Clear
    
   'Überschriftzeile in Ziel-Tabelle schreiben  
    Range(WksQ.Cells(1, DatenSpalteVon), WksQ.Cells(1, DatenSpalteBis)).Copy WksZ.Cells(1, ZielSpalte)
    
    Suchliste = Split(Eingabe, ",")  
    
    For Each Token In Suchliste
        If Token <> "" Then Call SearchAndCopy(WksQ, Trim(Token), WksZ)  
    Next
End Sub

Private Sub SearchAndCopy(ByRef WksQ, ByRef Token, WksZ)
    Dim Found As Range, FirstAddress As String, Zeile As Long
    
    With WksQ
        Set Found = .Range(SpalteSuchen).Find(Token, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
        
        If Not Found Is Nothing Then
            FirstAddress = Found.Address
            Do
                Zeile = WksZ.Cells(WksZ.Rows.Count, "C").End(xlUp).Row + 1  
                Range(.Cells(Found.Row, DatenSpalteVon), .Cells(Found.Row, DatenSpalteBis)).Copy _
                   WksZ.Cells(Zeile, ZielSpalte)
                Set Found = .Range(SpalteSuchen).FindNext(Found)
            Loop While Not Found Is Nothing And Found.Address <> FirstAddress
        End If
    End With
End Sub

Const SheetQuelle = "Daten"         ' Tabelle Daten/Suchen  
Const SheetZiel = "Vergleich"       ' Tabelle Suchergebnis  

Const SpalteSuchen = "C:C"          ' Spalte Suchen  
Const DatenSpalteVon = "A"          ' Daten kopieren von Spalte  
Const DatenSpalteBis = "F"          ' Daten kopieren bis Spalte  

Const ZielSpalte = "A"              ' Spalte Ziel-Tabelle  

Sub Suchen()
    Dim WksQ As Worksheet, WksZ As Worksheet, Suchliste As Variant, Token As Variant, Eingabe As String
    
    Eingabe = InputBox("Bitte Suchbegriffe Komma-Getrennt eingeben:", "Suchliste...")  
    
    If Eingabe = "" Then Exit Sub  
    
    Set WksQ = Sheets(SheetQuelle)
    Set WksZ = Sheets(SheetZiel):  WksZ.Cells.Clear
    
   'Überschriftzeile in Ziel-Tabelle schreiben  
    Range(WksQ.Cells(1, DatenSpalteVon), WksQ.Cells(1, DatenSpalteBis)).Copy WksZ.Cells(1, ZielSpalte)
    
    Suchliste = Split(Eingabe, ",")  
    
    For Each Token In Suchliste
        If Token <> "" Then Call SearchAndCopy(WksQ, Trim(Token), WksZ)  
    Next
End Sub

Private Sub SearchAndCopy(ByRef WksQ, ByRef Token, WksZ)
    Dim Found As Range, Suchtext As String, ZeileQ As Long, ZeileZ As Long
    
    With WksQ
        Suchtext = "*" & Token & "*"  'Teilübereinstimmung vor und nach mit "*"  
        If .Range(SpalteSuchen).AutoFilter(Field:=1, Criteria1:=Suchtext, VisibleDropDown:=False) Then
            ZeileQ = WksQ.Cells(WksQ.Rows.Count, "C").End(xlUp).Row  
            ZeileZ = WksZ.Cells(WksZ.Rows.Count, "C").End(xlUp).Row + 1  
            Range(.Cells(2, DatenSpalteVon), .Cells(ZeileQ, DatenSpalteBis)).Copy WksZ.Cells(ZeileZ, ZielSpalte)
        End If
       .AutoFilterMode = False
    End With
End Sub