Makro - Doppelte Zeilen finden und löschen
Chris
ich schreibe zur Zeit an meiner Masterarbeit und würde mich über einen guten Tipp zu meinem Excel Makro freuen. Ich arbeite noch nicht so lange mit Makros, brauche jedoch Makros um meine große Datenbank zu gestalten. Über Hilfe würde ich mich sehr freuen.
Damit klar ist worum es geht, anbei ein kurzer Ausschnitt meiner Datenbank:
https://www.herber.de/bbs/user/79483.xlsm
Ich habe auch schon ein Makro welches funktioniert, bei derzeit 130.000 Zeilen aber zeitlich versagt:
------------ Makro Code (1) -------------------------------------------------------------------- _ -----------------------
Sub Delete_Double_Entries_1()
Dim t As Single
t = Timer
Dim ii, jj As Long
For ii = 1 To Range("G130000").End(xlUp).Row
For jj = ii + 1 To Range("G130000").End(xlUp).Row
'## Delete row if at least the three given arguments are true;
'## ii is running through all rows and jj through all rows below ii
While Cells(ii, 9) = Cells(jj, 9) And Cells(ii, 6) = Cells(jj, 6) And Cells(ii, 3) = _
Cells(jj, 3) And Cells(ii, 2) = Cells(jj, 2) And Not (Cells(ii, 1) = Cells(jj, 1))
Rows(jj).Delete
Wend
Next jj
Next ii
Debug.Print Timer - t
End Sub
----------------------------------------------------------------------------------------------------------------------------
Mein Ziel ist es nun die Datanbank nach Proposal zu sortieren um dann Paketweise die Daten anzugehen. Und zwar wie folgt:
------------ Makro Code (2) -------------------------------------------------------------------- _ -----------------------
Sub Delete_Double_Entries_2()
Dim x, y As Long
Application.ScreenUpdating = False
For x = 1 To Range("G100").End(xlUp).Row
Do While Cells(x, 6) = Cells(x + 1, 6)
For y = x To y + 10
If Cells(y, 9) = Cells(y + 1, 9) And Cells(y, 6) = Cells(y + 1, 6) And Cells(y, 3) = _
_
Cells(y + 1, 3) And Cells(y, 2) = Cells(y + 1, 2) And Not (Cells(y, 1) = Cells(y + 1, 1)) Then
Rows(y + 1).Delete
End If
Next
Loop
Next
'Sheets("Output").Range("A1000000").End(xlUp).Offset(0, 1) = Rows(y + 1) And
Application.ScreenUpdating = True
End Sub
----------------------------------------------------------------------------------------------------------------------------
Mit "Cells(x, 6) = Cells(x + 1, 6)" soll das Proposalpaket abgearbeitet werden um nicht jedes Mal 130.000 Einträge abzuarbeiten.
" For y = x To y + 10" sollte dies auf die kommenden zehn Zeilen beschränken.
Anschließ soll eine als doppelt identifizierte Zeile (der Fondname muss anders sein) gelöscht werden. Wobei zur gewissenhaften Prüfung der Arbeit die Zeile idealerweise in ein anderes Blatt kopiert wird.
Fazit: Wenn das Makro funktioniert sollte in der Beispieldatei die grüne Ziele stehen bleiben, die rote abernicht.
Ich würde mich über Eure Hilfe sehr freuen. Ich hoffe ich konnte alle benötigten Informationen hier ablegen. Falls etwas unklar ist, eine kurze Nachricht im Forum wäre super :)
Anzeige