Re: Tabellen vergleichen
16.12.2002 10:00:48
L.Vira
Beachte meine Kommentare am Anfang des Codes. Es ist übrigens egal, ob es Doppler gibt oder nicht, der Code berücksichtigt das.''---------------------------------------------------------------
''Das erste zu vergleichende Blatt muss den Namen A haben.
''Das zweite zu vergleichende Blatt muss den Namen B haben.
''Das Blatt, in dem die Doppler aufgelistet werden, muss den
''Namen doppelt haben.
''Das Blatt, in dem die einmalig vorkommenden aufgelistet werden
''muss den Namen einfach haben.
''Die Blätter A und B dürfen nur Daten in Spalte A enthalten.
''Die oben angegebenen Voraussetzungen werden nicht geprüft!
''Bei Nichteinhalten der Bedingungen, kommt es zu Fehlern bei
''der Ausführung des Codes!
''---------------------------------------------------------------
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