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
|