AW: Doppelte Zeilen löschen
alex
hi olaf,
probier mal folgenden code. ich habe ihn hoffentlich ausreichend kommentiert:
ciao, alex
Sub duplikate()
Dim i As Long, iDuplikat As Long, DuplikatStartPos As Long, DuplikatEndPos As Long
Dim ZelleAktuelleZeile As String, ZelleNächsteZeile As String
Dim Duplikat As Boolean
i = 1
iDuplikat = 0
' bildschirmanzeige (aktualisierung) ausschalten (geht ddadurch sehr viel schneller)
'Application.ScreenUpdating = False
'Application.StatusBar = "bitte warten .."
' solange zelle in spalte a (1) nicht leer
While Cells(i, 1).Value <> ""
' zelle und nächste zelle einlesen
ZelleAktuelleZeile = Cells(i, 1).Value
ZelleNächsteZeile = Cells(i + 1, 1).Value
' wenn aktuelle und nächste zelle gleich, dann duplikat = wahr und zähler inkrementieren
If ZelleAktuelleZeile = ZelleNächsteZeile Then
Duplikat = True
iDuplikat = iDuplikat + 1
Else
Duplikat = False
End If
' wenn duplikat = falsch
If Duplikat = False Then
' und iduplikat >0 ist, also ein bereich mit duplikaten gefunden wurde
If iDuplikat > 0 Then
' start und endzeile der duplikate ermitteln
DuplikatStartPos = i - iDuplikat
DuplikatEndPos = i
' bereich der duplikate markieren
Range(Cells(DuplikatStartPos, 1), Cells(DuplikatEndPos, 6)).Select
' bereich der duplikate nach Spalte f (6) absteigend sortieren
Selection.Sort Key1:=Cells(DuplikatStartPos, 6), Order1:=xlDescending, Header:=xlNo ', Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
' allle zeilen ausser die erste innerhalb des bereichs ausschneiden
Rows(CStr(DuplikatStartPos + 1) & ":" & DuplikatEndPos).Delete Shift:=xlUp
'zählerkorrektur wegen des ausschneidens
i = i - (DuplikatEndPos - DuplikatStartPos)
End If
' den zähler wieder auf null stellen
iDuplikat = 0
End If
' zähler für nächste zeile
i = i + 1
Wend
' bildschirmanzeige (aktualisierung) wieder einschalten
'Application.ScreenUpdating = True
'Application.StatusBar = ""
End Sub