Hallo zusammen, habe mich an einem Programm versucht, das bei neuen Einträgen in eine Tabelle die alten Einträge überprüfen soll, und veraltete Einträge löschen soll. Zur Info: Nur die ersten 3 Spalten sind für mein Skript relevant. Die erste Spalte ist für jeden Eintrag befüllt (Inhalt unwichtig). In Spalte 2 wird markiert, ob der Eintrag "In Arbeit", also unvollständig, oder "Fertig", also final ist. In der 3ten Spalte wird eine Vertrags-ID angegeben. Die Liste wird nun laufend mit neuen Einträgen befüllt, manche davon sind noch nicht vollständig und somit als "in Arbeit" gelabelt. Neue Einträge zu einem bestimmten Vertrag werden als neue Zeile angelegt. Alles weitere ist im folgenden Skript kommentiert.
Sub AktuelleEintr()
' Es soll geprüft werden, ob zur entsprechenden Contract-ID bereits Einträge vorliegen.
' Ist der neue Eintrag als "Fertig" gelabelt UND gibt es bereits Einträge "In Arbeit"?
' In diesem Fall werden die "In Arbeit"-Einträge gelöscht und nur der aktuelle Eintrag beibehalten.
' Ablauf:
' Eintragung wird vorgenommen (auch mehrfach-Eintragungen möglich)
' Contract-ID wird überprüft
' Noch nicht vorhanden --> nichts passiert
' Bereits vorhandene Einträge mit Status auf "Fertig" --> nichts passiert
' Bereits vorhandene Einträge mit Status "In Arbeit" --> Einträge löschen
Dim z As Long, lZ As Long 'Variablen für meine Zeilen
Dim Contract As String 'Variable für meine Vertrags-ID
Dim Eintrag As range 'Range-Variable, die zum Auffinden bestimmter Vertrags-IDs verwendet wird
Dim Startw As String 'Startwert für späteren Loop
Worksheets("Gesamt DB").Select 'Ursprünglich eingeführt, da das Makro von einem anderen Sheet gelauncht werden soll
lZ = Worksheets("Gesamt DB").Cells(Rows.Count, 1).End(xlUp).Offset(-1, 0).Row 'lZ Ist meine letzte Zeile mit Eintrag. Der Offset kommt daher, da in der Tabelle stets eine Leerzeile am Ende steht
For z = lZ To 8 Step -1 'In Zeile 8 steht der erste Eintrag
Contract = Worksheets("Gesamt DB").Cells(z, 3).Value 'Unterste Vertrags-ID wird als Contract deklariert
If Worksheets("Gesamt DB").Cells(z, 2).Value = "Fertig" Then 'Wenn der neuste Eintrag als "Fertig" gelabelt ist...
Set Eintrag = Worksheets("Gesamt DB").range("C8", Cells(Rows.Count, 3).End(xlUp)).Find(Contract) 'In meiner Liste nach Einträgen mit der selben Vertrags-ID suchen
Startw = Eintrag.Address 'Startwert festlegen für späteren Loop
Do
If Eintrag.Offset(0, -1).Value = "In Arbeit" Then 'Wenn ein als "In Arbeit" gelabelter Eintrag besteht
Rows(Eintrag.Row).Value = "" 'Wird die Zeile geleert
End If
Set Eintrag = Worksheets("Gesamt DB").range("C8", Cells(Rows.Count, 3).End(xlUp)).FindNext(Eintrag) 'Nächste übereinstimmernde Vertrags-ID wird gesucht
Loop While Not Eintrag Is Nothing And Eintrag.Address <> Startw 'Soll einmal die ganze Liste durchchecken.
End If
If Worksheets("Gesamt DB").Cells(z, 1).Value = "" Then
Rows(z).Delete 'Zum Schluss sollen die Zeilen, die geleert wurden, noch gelöscht werden
End If
Next
End Sub
Problem: Ich bin mir nicht sicher, ob diese Loops gut genug geschlossen sind. Habe das Problem, dass sich bei Ausführung des Makros mein Excel aufhängt, ohne Fehlermeldung. Hat hier jemand ne Idee, wie das zu fixen wäre (oder eleganter zu lösen, bin leider VBA-technisch nicht gerade fit)? In etwa so sieht die Tabelle aus
Spalte 1 |
Fertig/In Arbeit |
Vertrags-ID |
xyz |
In Arbeit |
Test-ID*1 |
xyz |
Fertig |
Test-ID*1 |
xyz |
In Arbeit |
Test-ID*2 |
xyz |
Fertig |
Test-ID*2 |
In diesem Fall sollten hier Zeile 2 und 4 geleert und anschließend gelöscht werden
|