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 ganz 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
