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
Application.ScreenUpdating = False
Suchbegriff = InputBox("Bitte Suchbegriff eingeben:")
Suchliste = Split(Suchbegriff, ",")
If Suchbegriff = "" Then
Beep
MsgBox "Bitte einen Suchbegriff eingeben!", , Application.UserName
Exit Sub
End If
Set rng = Cells.Find(what:=Suchliste, LookAt:=xlWhole, LookIn:=xlValues, SearchOrder:=xlByRows, _
MatchCase:=True, After:=Range("A1"))
If rng Is Nothing Then
Beep
MsgBox "Suchbegriff nicht gefunden!", , Application.UserName
Exit Sub
End If
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
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"))
If Token <> "" Then
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
Application.ScreenUpdating = True
End Sub