Mit VBA eine Excel-Liste bereinigen
18.03.2014 09:14:19
Berliner85
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
Option Explicit
Const HomeDatei = "DUBLETTENBEREINIGUNG.xlsm" 'Name Arbeitsmappe Makro-Excel-Datei
Const HomeDaten = "Daten-Import" 'Name Tabellenblatt Daten-Import
Const HomeListe = "Datei-Liste" 'Name Tabellenblatt Datei-Liste
Const HomeZeile = 3 'Erste Zeile Einfügen
Const CopyZeile = 3 'Erste Zeile Kopieren
Const ListDatei = "A1" 'Zelle erster Dateiname
Const ErrMsg = "Abbruch! Datei existiert nicht: "
Sub SheetsImport()
Dim WksHome As Worksheet, WksList As Worksheet, EndLine As Integer, NextLine As Integer
Dim WkbCopy As Workbook, WksCopy As Worksheet, Fso As Object, File As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Set WksHome = Workbooks(HomeDatei).Sheets(HomeDaten)
Set WksList = Workbooks(HomeDatei).Sheets(HomeListe)
EndLine = GetEndLine(WksHome): NextLine = HomeZeile
If EndLine >= HomeZeile Then WksHome.Rows("3:" & EndLine).Cells.Clear
Application.ScreenUpdating = False
For Each File In WksList.Range(ListDatei).CurrentRegion
If Fso.FileExists(File) = False Then
Application.ScreenUpdating = True
MsgBox ErrMsg & File, vbExclamation, "Fehler": Exit Sub
End If
Set WkbCopy = Workbooks.Open(File): Set WksCopy = WkbCopy.Sheets(1)
EndLine = GetEndLine(WksCopy)
If EndLine >= CopyZeile Then
WksCopy.Rows("3:" & EndLine).Copy
WksHome.Rows(NextLine).Insert Shift:=xlDown
Application.CutCopyMode = False
WkbCopy.Saved = True: WkbCopy.Close
NextLine = GetEndLine(WksHome) + 1
End If
Next
Application.ScreenUpdating = True
End Sub
End With
End Sub
Hier der Code zum Importieren der Dateien: