Sub AktuelleEintr()
Dim z As Long, lZ As Long
Dim strContract As String
Dim rngEintrag As Range
Dim strStartw As String
Dim rngDel As Range
With Worksheets("Gesamt DB")
lZ = .Cells(.Rows.Count, 1).End(xlUp).Offset(-1, 0).Row
strContract = .Cells(lZ, 3).Value
If .Cells(lZ, 2).Value = "Fertig" Then
With .Range(.Cells(8, 3), .Cells(lZ - 1, 3))
If WorksheetFunction.CountIfs(.Columns(1), strContract) = 0 Then exit sub
Set rngEintrag = .Find(strContract, LookIn:=xlValues, XlLookAt:=xlWhole)
End With
If Not rngEintrag Is Nothing Then
strStartw = rngEintrag.Address
Do
If rngEintrag.Offset(0, -1).Value = "In Arbeit" Then
Set rngDel = IIf(rngDel Is Nothing, rngEintrag, Union(rngEintrag, rngDel))
End If
With .Range(.Cells(8, 3), .Cells(lZ - 1, 3))
Set rngEintrag = .FindPrevious(after:=rngEintrag)
End with
Loop While Not rngEintrag Is Nothing And rngEintrag.Address <> strStartw
End If
End If
if not rngdel is nothing then rngDel.EntireRow.Delete xlShiftUp
End With
Set rngDel = Nothing: Set rngEintrag = Nothing
End Sub