Hallo Mabi,
Hier mal ein Makro das zwei Tabellen abgleichen kann, abgestimmt auf deine Spalten.
Name, PLZ und Ort werden „hart“, d.h. auf exakte Übereinstimmung, verglichen. Bei der Strasse wird „weich“ geprüft, d.h. bei exakter Übereinstimmung wird der Eintrag abgeglichen; wird keine übereinstimmende Strasse gefunden, dann wird die Info von dem 1. Eintrag übernommen, bei dem Name, PLZ und Ort übereinstimmen. Strassennamen werden dann zusätzlich aus der Quelle in weitere Spalten übertragen, so dass ggf. der manuelle Abgleich erleichtert wird.
Gruß
Franz
Sub Datenabgleich()
'Daten aus zwei Tabellen abgleichen
Dim wbQuelle As Workbook, wksQuelle As Worksheet
Dim wbZiel As Workbook, wksZiel As Worksheet
Dim ZeileZiel As Long, Spalte As Long
Dim varName, varStrasse, varPLZ, varOrt
Dim strAdresse1 As String, Zelle As Range, gefunden As Boolean
Dim ZeileOhneStrasse As Long, varWeitere
'Tabelle mit vorhandenen Inhalten in Spalten E bis F
Set wbQuelle = Workbooks("Tabellen\_Datenabgleich.xls") 'Name anpassen!
Set wksQuelle = wbQuelle.Worksheets("Tabelle1") 'Name - anpassen
'Tabelle in der Inhalte aus Tabelle 1 eingetragen werden sollen
Set wbZiel = Workbooks("Tabellen\_Datenabgleich.xls") 'Name anpassen!
Set wksZiel = wbZiel.Worksheets("Tabelle2") 'Name - anpassen
For ZeileZiel = 2 To wksZiel.Cells(wksZiel.Rows.Count, 1).End(xlUp).Row
'Such-Werte aus Zeile in Zieltabelle einlesen
varName = wksZiel.Cells(ZeileZiel, 1).Value 'Name
varStrasse = wksZiel.Cells(ZeileZiel, 2).Value 'Adresse
varPLZ = wksZiel.Cells(ZeileZiel, 3).Value 'PLZ
varOrt = wksZiel.Cells(ZeileZiel, 4).Value 'Ort
'Name in Spalte A der Quelle suchen
Set Zelle = wksQuelle.Columns(1).Find(what:=varName, LookIn:=xlValues, \_
lookat:=xlWhole)
'Hilfswerte zurücksetzen
gefunden = False
ZeileOhneStrasse = 0
varWeitere = ""
If Not Zelle Is Nothing Then
'Adresse der 1. Fundstelle merken
strAdresse1 = Zelle.Address
Do
'Prüfen ob die anderen 3 Werte auch übereinstimmen
If varPLZ = wksQuelle.Cells(Zelle.Row, 3) \_
And varOrt = wksQuelle.Cells(Zelle.Row, 4) Then
If varStrasse = wksQuelle.Cells(Zelle.Row, 2) Then
gefunden = True
'Spalten E bis F übertragen
For Spalte = 5 To 7
wksZiel.Cells(ZeileZiel, Spalte).Value \_
= wksQuelle.Cells(Zelle.Row, Spalte).Value
Next
Exit Do
Else
'Zeile merken, wenn Name, PLZ und Ort übereinstimmen
If ZeileOhneStrasse = 0 Then
ZeileOhneStrasse = Zelle.Row
Else
'Weitere Strassen merken
If varWeitere = "" Then
varWeitere = wksQuelle.Cells(Zelle.Row, 2)
Else
varWeitere = varWeitere & wksQuelle.Cells(Zelle.Row, 2)
End If
End If
End If
End If
'Nächsten Namens-Eintrag suchen
Set Zelle = wksQuelle.Columns(1).FindNext(after:=Zelle)
Loop Until Zelle.Address = strAdresse1
End If
If gefunden = False And ZeileOhneStrasse \> 0 Then
'Spalten E bis F aus gemerkter Zeile übertragen
For Spalte = 5 To 7
wksZiel.Cells(ZeileZiel, Spalte).Value \_
= wksQuelle.Cells(ZeileOhneStrasse, Spalte).Value
Next
'Strasse aus Quelle eintragen in Spalte H
wksZiel.Cells(ZeileZiel, Spalte).Value \_
= wksQuelle.Cells(ZeileOhneStrasse, 2).Value
If varWeitere "" Then
'weitere Strassen eintragen in Spalte I, wenn Name, PLZ und Ort \_
mehrfach übereinstimmen
wksZiel.Cells(ZeileZiel, Spalte + 1).Value = varWeitere
End If
End If
Next
End Sub