Spalte durchlaufen - Liste mit Zusatzinfo erzeugen

Sub test44()
Quelle = "AQPL" 'Name der Tabelle mit den Quelldaten
QSpalte = "A" 'Spalte, in welcher gesucht wird
Spaltenanzahl = 2 'Anzahl daneben liegender Spalten, aus denen die Inhalte in die Zieldatei ü _
bertragen werden sollen
Ziel = "Mail" '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("AQPL")
Set z = Worksheets("Mail")
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