Sub FindAndCopy1()
Dim rngSuch As Range, wksSrc As Worksheet, wksDst As Worksheet
Dim strSuch As String, rngFound As Range
Dim strFirst As String, FoundAdr As String
Dim ZeSrc As Integer, ZeDst As Integer, lRow As Long, lRowDst As Long
Dim nTabelle As String, i As Integer
Dim lzeile As String
lzeile = Worksheets("Datenüberprüfung").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lzeile
nTabelle = Worksheets("Datenüberprüfung").Cells(i, 1).Value
Set wksSrc = Worksheets(nTabelle)
Set wksDst = Worksheets("Achtung")
lRow = wksSrc.Cells(Rows.Count, 1).End(xlUp).Row
Set rngSuch = wksSrc.Range("N6:N" & lRow)
With wksDst
lRowDst = WorksheetFunction.Max(6, .Cells(Rows.Count, 1).End(xlUp).Row)
wksDst.Range("A6:N" & lRowDst).EntireRow.Delete
If .Range("A1") = "" Then
End If
End With
strSuch = InputBox("Bitte das Suchwort eingeben", "Filter")
With rngSuch
Set rngFound = .Find(what:=strSuch)
If Not rngFound Is Nothing Then
strFirst = rngFound.Address
Do
FoundAdr = rngFound.Address
ZeSrc = rngFound.Row
ZeDst = wksDst.Cells(Rows.Count, 1).End(xlUp).Row + 1
wksSrc.Range("A" & ZeSrc & ":N" & ZeSrc).Copy wksDst.Cells(ZeDst, 1)
Set rngFound = .FindNext(rngFound)
Loop While Not rngFound Is Nothing And rngFound.Address <> strFirst
Else
MsgBox "Der Name '" & strSuch & "' wurde nicht gefunden!", vbInformation, "Fehleingebe?"
End If
End With
Next i
End Sub