Sub Vergleich()
Dim zells As Range
Dim x As Long
Dim rng As Range
Dim lastn As Long
Dim lasta As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Worksheets("Neudaten")
Set ws2 = Worksheets("Altdaten")
lastn = ws1.Cells(1048576, 2).End(xlUp).Row
lasta = ws2.Cells(1048576, 2).End(xlUp).Row
With ws1.Range("B2:B" & lastn)
.NumberFormat = General
.Value = .Value
Set objDic = CreateObject("Scripting.Dictionary")
Dim v, e
With ws2.Range("B2:B" & lasta)
v = .Value
End With
For Each e In v
If Not objDic.Exists(e) Then objDic.Add e, e
Debug.Print e
Next
Set rng = ws1.Range("B2:B" & lastn)
With ws2.Cells.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ws2.Cells.Columns(30).Clear
For Each zells In rng
lasta2 = ws2.Cells(1048576, 2).End(xlUp).Row
If Not objDic.Exists(zells.Value) Then
ws1.Range("A" & zells.Row & ":" & "K" & zells.Row).Copy ws2.Range("A" & lasta2 + 1)
ws2.Range("L" & lasta2 + 1) = "Neu"
End If
Next
Set objDic = Nothing
Set objDic2 = CreateObject("Scripting.Dictionary")
Dim b, c
With ws1.Range("B2:B" & lastn)
b = .Value
End With
For Each c In b
If Not objDic2.Exists(c) Then objDic2.Add c, c
Debug.Print c
Next
Dim zells2 As Long
lasta2 = ws2.Cells(1048576, 2).End(xlUp).Row
For zells2 = 2 To lasta2
If ws2.Cells(zells2, 2).Value = "" Then GoTo XXX
If Not objDic2.Exists(ws2.Cells(zells2, 2).Value) Then
ws2.Rows(zells2).Delete Shift:=xlUp
zells2 = zells2 - 1
End If
XXX:
Next
Set objDic2 = Nothing
End With
With Worksheets("Altdaten")
.Columns("A:AC").Sort Key1:=.Range("J2"), Order1:=xlDescending, Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
End With
MsgBox "Vergleich beendet!"
End Sub