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
|