Zelleninhalt suchen und 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