Doppelte Einträge löschen, und farblich markieren
14.01.2005 14:12:56
Carsten
Ich hab ein kleines Problem, und hoffe auf Eure fachmännische Hilfe:
-Ausgangsmaterial ist eine Adress/Kundendatei in Excel 2003 mit Überschrift
- Doppelte bzw. 3-fach vorkommende Einträge sollen bis auf einen gelöscht werden
- der übrig gebliebene Eintrag soll farblich markiert werden
- das ganze sollte automatisch ablaufen. D.h. bei einem Neueintrag am Ende der Liste soll diese nach Spalte D sortiert werden und o.g. Prüfung stattfinden. (oder anders herum)
Bei Änderung welcher Zelle das Programm startet ist eigentlich egal.
- Spalte A: Anrede
- Spalte B: Vorname (kommt nicht immmer vor. Also evtl. leere Zelle)
- Spalte C: Nachname
- Spalte D: Firma (nach dieser Zelle soll selektiert !!UND!! sortiert werden)
- Spalte E: Anschrift
- Spalte F: PLZ (fehlt auch ab und zu)
- Spalte G: Tel.
- ...bis Spalte K
Über "Spezial- oder Autofilter" funktioniert das ganze leider nicht.
Auch mit Hilfe von Daten ... Gültigkeit ... Vergleich stellt sich nicht das gewünscht Ergebnis ein.
Ich werde wohl nicht drum herum kommen, das ganze in vba zu machen.
Ein netter Mitmensch (vielen Dank Werner!!) hat sich meines Problems angenommen, und folgende Lösung ausgetüftelt:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim laR As Long, i As Long
If Target.Column <> 4 Then Exit Sub
laR = Cells(Rows.Count, 2).End(xlUp).Row
Range("A2:K" & laR).Sort Key1:=Range("D2"), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
For i = laR To 2 Step -1
If Cells(i, 2).Value = Cells(i - 1, 2).Value Then
Rows(i).Delete Shift:=xlUp
Cells(i - 1, 2).Interior.ColorIndex = 6
End If
Next i
End Sub
Das Programm funktioniert leider nicht ganz richtig. Es werden mir einfach viel zu viele Daten gelöscht, und ich finde den Fehler nicht.
MfG
Carsten
Anzeige