doppelte Datensätze löschen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Kerstin
Ich hab mal in meiner alten Makrosammlung ein Programm aus Vorzeiten gefunden (sähe heute sicherlich anders aus).
Umständlich sind anfangs die erforderlichen Eingaben, dafür aber dann universaleinsetzbar. Funktioniert auch.

Public Sub Doppel_löschen()
Dim i%, n%, Z%, j%, S%, s1%, s2%
Dim a As Date, b As Date, C As Date
Dim ErsterWert$, ZweiterWert$
    a = Now
    Application.ScreenUpdating = False
'erste Zeile mit Daten
        Mldg = "Nr. der ersten Datenzeile eingeben"
        Titel = "Vorbereitungen:" ' Titel festlegen.
        Voreinstellung = "2"    ' Voreinstellung festlegen.
        n = InputBox(Mldg, Titel, Voreinstellung, 2000, 4000)
        If n < 1 Then GoTo FERTIG:
'Spalte, in der keine leeren Zellen existieren
        Mldg = "Nr. einer Spalte angeben, die keine leeren Zellen enthält"
        Titel = "Zeilenanzahl ermitteln" ' Titel festlegen.
        Voreinstellung = "1"    ' Voreinstellung festlegen.
        S = InputBox(Mldg, Titel, Voreinstellung, 2000, 4000)
        If S < 1 Then GoTo FERTIG:

'Das sind die Spalten, in denen die zu vergleichenden Sätze enthalten sind
'Erste Spalte, die durchsucht werden soll
        Mldg = "Nr.(1) der Spalte angeben, die gefiltert werden soll"
        Titel = "Filterspalte 1 angeben" ' Titel festlegen.
        Voreinstellung = "1"    ' Voreinstellung festlegen.
        s1 = InputBox(Mldg, Titel, Voreinstellung, 2000, 4000)
        If s1 < 1 Then GoTo FERTIG:
'Zweite Spalte, die durchsucht werden soll
        Mldg = "Nr.(2) der Spalte angeben, die auch verglichen werden soll"
        Titel = "Filterspalte 2 angeben" ' Titel festlegen.
        Voreinstellung = "1"    ' Voreinstellung festlegen.
        s2 = InputBox(Mldg, Titel, Voreinstellung, 2000, 4000)
        If s2 < 1 Then GoTo FERTIG:
'Zählen der Datensätze
    Z = n
    Do While Cells(Z, S).Value <> ""
        Z = Z + 1
    Loop
    vor = Z 'Anzahl Zeilen vorher
'    Die folgende Schleife löscht alle folgenden Zeilen,
'    in denen die Daten in Spalte s1 und in Spalte s2
'    gleich der gerade mit der ersten For-Schleife gewählten
'    sind
    S = 0
    For i = n To Z
        ErsterWert = Cells(i, s1).Value
        ZweiterWert = Cells(i, s2).Value
        'Löschen der Folgezeilen, wenn die genannten Daten gleich sind
        For j = i + 1 To Z
            If Cells(j, s1).Value = ErsterWert And Cells(j, s2).Value = ZweiterWert Then
                Rows(j).Delete
                j = j - 1
                Z = Z - 1
                If Z = 0 Then GoTo FERTIG:
                Application.StatusBar = Format(100 * i / Z, "0.00") & "%"
            End If
'###Anstelle Löschen nur rot färben## Bei Bedarf
'            If Cells(j, s1).Value = ErsterWert And Cells(j, s2).Value = ZweiterWert Then
'                Rows(j).Interior.ColorIndex = 3
'                'j = j - 1
'                Z = Z - 1
'                If Z = 0 Then GoTo FERTIG:
'                Application.StatusBar = Format(100 * i / Z, "0.00") & "%"
'            End If
        Next j
    Next i
FERTIG:
    Application.StatusBar = False
    b = Now
    C = CDate(b - a)
    gel = vor - Z 'Anzahl gelöschte Zeilen
    Meldung = "Gelöscht wurden " & gel & " Zeilen. Dauer: " & C
    Application.ScreenUpdating = True
    MsgBox Meldung
End Sub

Gruß UD

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

doppelte Datensätze löschen

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread