Hallo zusammen,

ich habe das Forum nach ähnlichen Beiträgen schon durchsucht, doch leider war keine passende Lösung dabei, daher hoffe ich auf Ihre Unterstützung. Bin in VBA noch totaler Anfänger.

Situation ist folgende: über eine Importfunktion werden aus zwei Excel-Dateien die Inhalte kopiert und zusammengefasst. Es handelt sich um Kundenlisten.

Liste A = BESTAND
Liste B = NEU

Folgende Spalten werden innerhalt der Listen verwendet:
Name, Vorname, Straße, Hausnr., PLZ, Ort, Telefon

Nun wurde mir eine Funktion geschrieben, die Dubletten löscht, jedoch mit einer Besonderheit.

Sobald doppelte Datensätze sich in drei von vier festgelegten Kriterien gleichen, sollen BEIDE Datensätze gelöscht werden.

Die vier Kriterien entsprechen den vier Spalten Name, Vorname, PLZ, Telefon

Nochmal zum Verständnis... es soll eine Kontaktliste erstellt werden. Möglicherweise gibt es mehrere Hans Müller, aber sobald der Datensatz "Hans Müller" die gleiche PLZ oder TELEFON enthält, sollen BEIDE vergleichende Datensätze (oder mehrere) gelöscht werden.

Anschließend wird die Liste nach Name aufsteigend sortiert.

Die Lösung, die ich habe, funktioniert soweit sehr gut. ABER ich hatte einen Denkfehler, der mich nun völlig überfordert.

Derzeit werden die Daten aus Liste BESTAND und Liste NEU importiert, in eine Liste zusammengefügt und um Dubletten bereinigt.

Richtig soll aber sein, dass aus der Liste NEU alle Datensätze gelöscht werden, die BESTAND enthält und DANACH die Daten aus BESTAND komplett gelöscht werden sollen.

So das eine Liste NEU bereinigt mit BESTAND entsteht.

Können Sie mir da helfen? Wo setze ich an??

Hier der Code zum Bereinigen:
 

Sub Dublettenbereinigung()
Dim Spalten(1 To 4) As Long
Dim sp As Long
Dim i As Long
Dim Fo As String

'--- Hier Zeilen- und Spaltennummern eintragen

Const ErsteDatenZeile As Long = 3
Spalten(1) = 1 ' Spaltennummer Name
Spalten(2) = 2 ' Spaltennummer Vorname
Spalten(3) = 5 ' Spaltennummer PLZ
Spalten(4) = 7 ' Spaltennummer Telefon


'--- Prüfformel für Duplikate erstellen
Fo = "=If(or(((RCw=R[-1]Cw)+(RCx=R[-1]Cx)+(RCy=R[-1]Cy)+(RCz=R[-1]Cz))>=3,((RCw=R[1]Cw)+(RCx=R[1]Cx)+(RCy=R[1]Cy)+(RCz=R[1]Cz))>=3),1,"""")"

For i = 1 To 4
    Fo = Replace(Fo, Chr(Asc("v") + i), Spalten(i))
Next

With Range(Cells(ErsteDatenZeile, 1), Cells.SpecialCells(xlCellTypeLastCell))
    For i = 1 To 4
        '--- Sortieren, so das Duplikate untereinander stehen
        For sp = 1 To 4
            If sp <> i Then .Sort Key1:=.Cells(1, Spalten(sp)), order1:=xlAscending, Header:=xlNo
        Next
        '--- per Formel auf Dupliakte prüfen und Zeilen löschen
        With .Columns(.Columns.Count + 1)
            .FormulaR1C1 = Fo
            .Formula = .Value
            If WorksheetFunction.Sum(.Cells) > 0 Then
                .EntireRow.Sort Key1:=.Cells(1, 1), order1:=xlAscending, Header:=xlNo
                .SpecialCells(xlCellTypeConstants, 1).EntireRow.Delete
            End If
            .ClearContents
        End With
    Next
   
    '--- Sortieren nach Namen
   .Sort Key1:=.Cells(1, Spalten(1)), order1:=xlAscending, key2:=.Cells(1, Spalten(2)), order2:=xlAscending, Header:=xlNo

End With

End Sub