|
Hallo,
vielen Dank an Volti, für das unten aufgelistete Makro. Funktioniert super!!! Leider habe ich zu wenig Erfahrung in VBA, um folgende Optionen zu erweitern:
- Würde gerne statt einer Inputbox zwei Buttons haben, einmal mit München und einmal mit Hamburg, zum anklicken. Buttons sollen in der Mitte von Tabelle 1 erscheinen und sobald eine Auswahl getroffen wurde, müssten die Daten aus Tabelle 2 übernommen werden und die Buttons dann verschwinden.
- Bei Auswahl München, sollen alle Zeilen aus Tabelle 2, in denen München in der Spalte B vorkommen, in Tabelle 1 übertragen werden. Soweit war meine Anfrage beim letzten Mal und das Makro, das ich dafür bekommen habe ist genial.
- Statt die ganze Zeile, in der München vorkommt, sollen jetzt nur beispielsweise Spalten B, F und G übernommen werden.
- Die Auflistung sollte dann in Tabelle 1, ab Zelle B2 beginnen.
- Angenommen, in Spalte F steht das Wort Oktoberfest, kann der Zellwert dann in Tabelle 2 als OF übernommen werden, da die Spalte schmäler ist?
Vielen Dank schon mal! Ihr seid der Hammer!!!
Option Explicit
Sub Suchen()
Dim oFinde As Object
Dim sSuch As String, sErsteAdresse As String
Dim iAnz As Integer, iOutZeile As Long
Dim WShZ As Worksheet, WShQ As Worksheet
' Suchbegriff abfragen (optional,ggf. abändern, entfernen)
sSuch = InputBox("Bitte Suchbegriff eingeben!", "Kopieren")
If StrPtr(sSuch) = 0 Then Exit Sub
If sSuch = "" Then Exit Sub
' Quell- und Zielblatt setzen
Set WShQ = Worksheets("Tabelle1") ' <<<anpassen>>>
Set WShZ = Worksheets("Tabelle2") ' <<<anpassen>>>
' Erstes Feld mit dem Suchbegriff suchen
Set oFinde = WShQ.Range("A:A").Find(sSuch, LookIn:=xlValues, LookAt:=xlWhole)
If Not oFinde Is Nothing Then
sErsteAdresse = oFinde.Address ' Erste Adresse merken
Do
iOutZeile = iOutZeile + 1 ' Nächste Ausgabezeie
oFinde.EntireRow.Copy WShZ.Cells(iOutZeile, "A") ' Zeile kopieren
Set oFinde = WShQ.Range("A:A").FindNext(oFinde) ' Nächsten Suchbegriff suchen
If oFinde Is Nothing Then Exit Do
Loop While Not oFinde Is Nothing And oFinde.Address <> sErsteAdresse
End If
End Sub
|