Hallo,

da find bereits deine Liste durchsucht, benötigst du keine for schleife mit der du nochmals alles durchgehst. Der Vorgang wird ja sicher nach jedem Contracteintrag ausgeführt.    

rngdel sammelt die zur Löschung vorgemerkten Bereiche und am Ende wird gelöscht.  

countifs soll schon mal checken ob die Contractid mehrfach vorkommt. Wenn nicht wird die Sub beendet.

Sub AktuelleEintr()
 
Dim z As Long, lZ As Long       'Variablen für meine Zeilen
Dim strContract As String          'Variable für meine Vertrags-ID
Dim rngEintrag As Range            'Range-Variable, die zum Auffinden bestimmter Vertrags-IDs verwendet wird
Dim strStartw As String            'strStartwert für späteren Loop
Dim rngDel As Range

With Worksheets("Gesamt DB")   'Ursprünglich eingeführt, da das Makro von einem anderen Sheet gelauncht werden soll
 
    lZ = .Cells(.Rows.Count, 1).End(xlUp).Offset(-1, 0).Row   'lZ Ist meine letzte...... eine Leerzeile am Ende steht
     
    'For z = lZ To 8 Step -1                                                             'In Zeile 8 steht.....Eintrag
        
    strContract = .Cells(lZ, 3).Value                                                 'Unterste .....ct deklariert
    
    If .Cells(lZ, 2).Value = "Fertig" Then                                            'Wenn .... "Fertig" gelabelt ist.
       
       With .Range(.Cells(8, 3), .Cells(lZ - 1, 3))
          
           'Abbruch wenn Id oberhalb nicht vorhanden
           If WorksheetFunction.CountIfs(.Columns(1), strContract) = 0 Then exit sub
     
           Set rngEintrag = .Find(strContract, LookIn:=xlValues, XlLookAt:=xlWhole)   'In meiner........trags-ID suchen
       
       End With
        
        If Not rngEintrag Is Nothing Then
                       
            strStartw = rngEintrag.Address           'strStartwert festlegen für späteren Loop
            
            Do
                If rngEintrag.Offset(0, -1).Value = "In Arbeit" Then   'Wenn ein als .......... rngEintrag besteht 
                    Set rngDel = IIf(rngDel Is Nothing, rngEintrag, Union(rngEintrag, rngDel))  'zur Lös ...vorgemerkt                                    
                End If
                With .Range(.Cells(8, 3), .Cells(lZ - 1, 3))
                    Set rngEintrag = .FindPrevious(after:=rngEintrag)           'Nächste ereinstimm................                               
                End with 
                
            Loop While Not rngEintrag Is Nothing And rngEintrag.Address <> strStartw   'Soll ..........durchchecken.
        End If
    End If
     
    if not rngdel is nothing then rngDel.EntireRow.Delete xlShiftUp 'löschen

End With

Set rngDel = Nothing: Set rngEintrag = Nothing

End Sub