Hallo zusammen,

ich bin Anfänger und habe schon versucht die antwort im Forum zu finden, leider bisher erfolglos.

Ich habe in einer Tabelle eine große Datenliste die ich nach Ortsnamen durchsuchen möchte. Da es sich um Ortsnamen die einer Verbandsgemeinde zugeortnet werden, können es auch mal >70 Orte sein nach denen die Daten durchsucht werden sollen. Diese sind in einem zweiten Tabellenblatt aufgelistet (Verbandsgemeinde und in der Spalte die Ortsnamen).

Ziel soll es sein über einen Butten die jeweilige Verbandsgemeinde auszuwählen (Liste mit Ortsnamen= Suchkiterien) und eine Tabelle mit den gefundenen Daten zu erstellen (komplette Zeile zum gefundenen Suchkiterium muss kopiert werden).

Aktuelle wird dies noch mit einer Inputbox durchgeführt aber ich schaffe es nicht nach mehreren Suchkiterien zu Suchen.

Ich hoffe jemand kann mir helfen.

Anbei der Quellcode nach aktuellem Stand:

Option Explicit
 
Sub SuchkiteriumOrt()
Dim rng As Range
Dim Suchbegriff As String
Dim Antwort As String
Dim wksOrig As Worksheet
Dim rngNeueZelle As Range
Dim Suchliste As Variant
Dim Token As Variant
Dim XO As Boolean

XO = True

 
' Auschalten der Bildschirmaktualisierung
Application.ScreenUpdating = False
 
' Abfrage des Suchwortes in der aktuellen Tabelle
Suchbegriff = InputBox("Bitte Suchbegriff eingeben:")
Suchliste = Split(Suchbegriff, ",")
 
' Wenn kein Suchbegriff eingegeben wurde = Fehlermeldung
If Suchbegriff = "" Then
  Beep
  MsgBox "Bitte einen Suchbegriff eingeben!", , Application.UserName
  Exit Sub
End If
 
' Suchroutine
Set rng = Cells.Find(what:=Suchliste, LookAt:=xlWhole, LookIn:=xlValues, SearchOrder:=xlByRows, _
  MatchCase:=True, After:=Range("A1"))     ' Activecell halte ich für nicht optimal

 
' Wenn Suchbegriff nicht in Tabelle = Fehlermeldung
If rng Is Nothing Then
  Beep
  MsgBox "Suchbegriff nicht gefunden!", , Application.UserName
  Exit Sub
End If
 
' Suchbegriff inklusive der kompletten Zeile kopieren und in neue Tabelle mit Namen des Suchbegriffs einfügen
If XO = True Then
Set wksOrig = ActiveSheet
Antwort = rng.Address
Rows(rng.Row).Copy
Sheets.Add
ActiveSheet.Name = Suchbegriff
Set rngNeueZelle = Sheets(Suchbegriff).Range("A1")
rngNeueZelle.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Rows(rngNeueZelle.Row).Insert Shift:=xlDown
End If

' Weitersuchen in der aktiven Tabelle nach dem Suchbegriff und wenn gefunden, in Tabelle mit Namen Suchbegriff einfügen
wksOrig.Activate
Cells.FindNext(After:=rng).Activate
While ActiveCell.Address <> rng.Address
  Rows(ActiveCell.Row).Copy
  Sheets(Suchbegriff).Activate
  Rows("1:1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
  Rows("1:1").Insert Shift:=xlDown
  wksOrig.Activate
  Cells.FindNext(After:=ActiveCell).Activate
Wend

XO = False

For Each Token In Suchliste
Set rng = Cells.Find(what:=Token, LookAt:=xlWhole, LookIn:=xlValues, SearchOrder:=xlByRows, _
  MatchCase:=True, After:=Range("A1"))     ' Activecell halte ich für nicht optimal
  
If Token <> "" Then

' Weitersuchen in der aktiven Tabelle nach dem Suchbegriff und wenn gefunden, in Tabelle mit Namen Suchbegriff einfügen
wksOrig.Activate
Cells.FindNext(After:=rng).Activate
While ActiveCell.Address <> rng.Address
  Rows(ActiveCell.Row).Copy
  Sheets(Suchbegriff).Activate
  Rows("1:1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
  Rows("1:1").Insert Shift:=xlDown
  wksOrig.Activate
  Cells.FindNext(After:=ActiveCell).Activate
Wend
End If


Next

' Einschalten der Bildschirmaktualisierung
Application.ScreenUpdating = True
End Sub

Gruß Rafael