Zelleninhalt suchen und den Inhalt von 2 Spalten daneben ausgeben

Sub Filtern()
Quelle = "Tabelle1" 'Name der Tabelle mit den Quelldaten  
QSpalte = "B" 'Spalte, in welcher gesucht wird  
Spaltenanzahl = 2 'Anzahl daneben liegender Spalten, aus denen die Inhalte in die Zieldatei übertragen werden sollen  

Ziel = "Tabelle2" 'Tabellenname für gefilterte Daten  
AbZZeile = 2 'Eintragen der gefilterten Daten ab dieser Zeile  
ZSpalte = "A" 'Eintragen der gefilterten Daten ab dieser Spalte  

Do Until Suche <> "" 'keine leere Eingabe akzeptieren  
    Suche = InputBox("Bitte den Suchbegriff eingeben (oder mit Eingabe von 'Ende' abbrechen):", "Suchbegriff")  
Loop
If LCase(Suche) = "ende" Then Exit Sub 'Abbruch  

Set Q = Worksheets(Quelle)
Set Z = Worksheets(Ziel)
ZZeile = AbZZeile 'Startzeile in Zieldatei setzen  

With Q.Columns(QSpalte)
    Set Gefunden = .Find(Suche, LookIn:=xlValues) 'gesamte Spalte der Quelldatei durchsuchen  
    If Not Gefunden Is Nothing Then 'nur wenn der Suchbegriff auch gefunden wurde, die folgenden Schritte durchführen  
        Erste = Gefunden.Address 'erste Fundstelle merken  
        Do 'für alle Fundstellen  
            Z.Cells(ZZeile, ZSpalte).Resize(1, Spaltenanzahl) = Gefunden.Offset(0, 1).Resize(1, Spaltenanzahl).Value 'Werte der Nachbarzellen übertragen  
            ZZeile = ZZeile + 1 'Zeilennummer der Zieltabelle erhöhen  
            Set Gefunden = .FindNext(Gefunden) 'nächste Fundstelle suchen  
        Loop Until Gefunden.Address = Erste 'bis wieder erste Fundstelle gefunden wird (= alle erledigt)  
    End If
End With
MsgBox "Fertig."  
End Sub