Datenabgleich
28.08.2003 14:57:55
Magnus
Ich möchte zwei Adressdatensätze A und B miteinander vergleichen.
Der Spaltenaufbau der Daten sieht in etwa so aus:
Unternehmen/Strasse/Nr./PLZ/Ort usw...
Verglichen werden soll nur das Unternehmen (Spalte A) und als Ergebnis werden einfache und doppelte Einträge auf zwei neuen Datenblättern ausgegeben. Folgendes Makro funktioniert prima, aber nur für Einträge in Spalte A. Steht etwas in den Spalten B,C,D ... bekomme ich eine Fehlermeldung.
Wie muss ich das Makro anpassen (im Archiv gefunden), damit im Ergebnis alle Spalteneinträge in die neuen Datenblätter übernommen werden?
Danke für Eure Hilfe, Magnus.
Option Explicit
Sub Vergleich()
Dim S1 As Worksheet, S2 As Worksheet, Einfach As Worksheet, Doppelt As Worksheet
Dim C As Range, SB As Variant, Z As Long, lZ As Long
Set S1 = Sheets("A")
Set S2 = Sheets("B")
Set Einfach = Sheets("einfach")
Set Doppelt = Sheets("doppelt")
Einfach.Columns(1).ClearContents
With Einfach
.[a1] = "einfach"
.[a1].Font.Bold = True
End With
Doppelt.Columns(1).ClearContents
With Doppelt
.[a1] = "doppelt"
.[a1].Font.Bold = True
End With
Application.ScreenUpdating = False
S1.Columns(1).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=S1.Columns(2), Unique:=True
S2.Columns(1).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=S2.Columns(2), Unique:=True
lZ = S1.[b65536].End(xlUp).Row
For Z = 2 To lZ
SB = S1.Cells(Z, 2)
With S2.Columns(2)
Set C = .Find(SB, LookIn:=xlValues, Lookat:=xlWhole, SearchOrder:=xlByColumns)
If Not C Is Nothing Then
Doppelt.[a65536].End(xlUp).Offset(1, 0) = SB
Else
Einfach.[a65536].End(xlUp).Offset(1, 0) = SB
End If
End With
Next
ENDE:
S1.Columns(2).ClearContents
S2.Columns(2).ClearContents
Application.ScreenUpdating = True
Set C = Nothing
Set S1 = Nothing
Set S2 = Nothing
Set Einfach = Nothing
Set Doppelt = Nothing
End Sub