Zelleninhalt suchen und Spalten daneben ausgeben
19.12.2018 12:07:18
Sandro
folgender automatisierter Wunsch besteht. (Wenn nötig via vba)
Tabelle 1 = Fahrtenbuch
Tabelle 2 = Fortlaufende eindeutige Kundenliste mit entsprechenden Infos
Folgenden funktionierenden Code habe ich bereits gefunden.
Dieser sucht via Msgbox in Tabelle 2 die eingegebene Kundennummer und überträgt die neben dem Treffer in Tabelle 2 stehenden Spalten, in Zeile 3 der Tabelle 1.
Nun überschreibt er jedoch beim 2. Aufruf die Werte in der Zeile 3 Tabelle 1.
Ich möchte jedoch fortlaufende Einträge vornehmen. Es soll quasi immer die nächste (leere) Zeile gefüllt werden.
Kann mir jemand sagen wir ich aus "AbZZeile = 3" beim nächsten msgbox Aufruf "AbZZeile = 4" bekomme?
Vielen Dank
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