Code eingefügt mit Syntaxhighlighter 1.16
ub MultiSeek()
'Original Unknown
'Modified by Ramses
'Sucht in der gesamten Mappe nach einem Begriff und kopiert die
'gefundene Zeile in eine zu definfierende Ergebnistabelle
Dim wks As Worksheet
Dim rng As Range
Dim sAddress As String, sFind As String
Dim Cr As Long, tarWks As String
tarWks = "Tabelle2" 'Name_der_Zieltabelle
Cr = 65536
If Worksheets(tarWks).Cells(Cr, 1) = "" Then
Cr = Worksheets(tarWks).Cells(Cr, 1).End(xlUp).Row
End If
If Cr = 0 Then Cr = 1
sFind = InputBox("Bitte Suchbegriff eingeben:")
For Each wks In Worksheets
If wks.Name = tarWks Then GoTo Exitfor
Set rng = wks.Cells.Find(what:=sFind, _
lookat:=xlWhole, LookIn:=xlFormulas)
If Not rng Is Nothing Then
sAddress = rng.Address
Do
Application.GoTo rng, True
If MsgBox("Weiter und kopieren", vbYesNo + vbQuestion) = vbNo Then Exit Sub
wks.Rows(rng.Row).Copy Destination:=Worksheets(tarWks).Rows(Cr)
Cr = Cr + 1
Set rng = Cells.FindNext(after:=ActiveCell)
If rng.Address = sAddress Then Exit Do
Loop
End If
Exitfor:
Next wks
MsgBox prompt:="Keine neue Fundstelle!"
End Sub