Guten Morgen zusammen,

ich habe leider nur mäßige Erfahrungen mit VBA und die Codes sind meist nur zusammenkopiert, daher kann ich aktuell folgendes
Problem nicht lösen:

Die Suchfunktion funktioniert im großen und ganzen. 
Allerdings sucht der Code aktuell nur das letzte Tabellenblatt (nTabelle; aktuell Fünf Tabellenblätter die er durchsuchen soll)
in meiner Liste (Datenüberprüfung) durch. Außerdem habe ich das Problem, dass er die Zeile teilweise öfter kopiert, weil er den
Suchbegriff öfter in der Zeile vorfindet. 

1. Gibt es eine Möglichkeit den Code so umzuschreiben, dass sobald die Zeile einmal kopiert 
wurde er zur nächsten Zeile springt und dort weitersucht?

2. Wie muss man den Code / die Schleife so umschreiben, dass er nacheinander alle Tabellenblätter durchsucht?

Vielen Dank vorab und nun der Code:

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




'Schleife Funktioniert nicht (nimmt nur letztes tabellenblatt als wert)

 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)   'Quelle
   Set wksDst = Worksheets("Achtung")   'Wohin kopiert werden soll
   lRow = wksSrc.Cells(Rows.Count, 1).End(xlUp).Row
   Set rngSuch = wksSrc.Range("N6:N" & lRow) 'Status suchen
   With wksDst
      lRowDst = WorksheetFunction.Max(6, .Cells(Rows.Count, 1).End(xlUp).Row)
      wksDst.Range("A6:N" & lRowDst).EntireRow.Delete 'Alle Namen-Einträge löschen
      If .Range("A1") = "" Then  'Wichtig, damit in A1 etwas steht (eventuell anpassen)
 '        .Cells(1, 1) = "Namte"
  '       .Cells(1, 2) = "Vorname"
 '        .Cells(1, 3) = "Fraktion"
      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) 'Zeile von Spalte A bis N kopieren
            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