Mit VBA Daten aus externen Quellen importieren und verarbeiten

Hallo zusammen,

ich möchte eine neue Liste erstellen mit Kontakten, die noch nicht im Bestand auftauchen.

Als ersten Schritt lade ich den Inhalt aus den beiden externen Quellen (Excel) in mein Datenblatt.

1. Datei = BESTANDSKUNDEN.xls
2. Datei = NEUEADRESSEN.xls

Beide Tabellen haben den Aufbau Name, Vorname, Straße, PLZ, Ort, Telefon

Code:

Option Explicit

Const HomeDatei = "Telefonliste.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


Im zweiten Schritt lösche ich zunächst Dubletten (doppelte Datensätze), die drei von vier Kriterien erfüllen. Nämlich wenn drei von vier Spalteninhalten Name, Vorname, PLZ oder Telefon identisch sind.

Bis hier funktioniert alles wunderbar.

Code:

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


Nun möchte ich aber in einem dritten Schritt alle Datensätze aus meiner importierten Liste löschen, die in der Datei BESTANDSDATEN.xls vorhanden sind.

So soll dann am Ende folgende Liste angezeigt werden.

=NEUE ADRESSEN+BESTANDSKUNDEN-DOPPELTE EINTRÄGE-BESTANDSKUNDEN

Hierfür fehlt mir das Verständnis. Können Sie mir da weiterhelfen?

Einen schönen Sonntag.