Tabellenabgleich durch Makro

Sub Abgleich()
Dim vnt1 As Variant, vnt2 As Variant, vntMark() As Variant
Dim rng As Range
Dim lngIndex As Long, lngC As Long
Sheets("Abgleich").Range("A2:V" & Rows.Count).ClearContents
With Sheets("Materialliste_neu")
vnt1 = .Range("B2:B" & Application.Max(2, .Cells(.Rows.Count, 2).End(xlUp).Row))
End With
With Sheets("Materialliste")
vnt2 = .Range("B2:B" & Application.Max(2, .Cells(.Rows.Count, 2).End(xlUp).Row))
End With
With Sheets("Materialliste_neu")
For lngIndex = 1 To UBound(vnt1, 1)
If IsError(Application.Match(vnt1(lngIndex, 1), vnt2, 0)) Then
ReDim Preserve vntMark(lngC)
vntMark(lngC) = "Neu"
lngC = lngC + 1
If rng Is Nothing Then
Set rng = .Range(.Cells(lngIndex + 1, 1), .Cells(lngIndex + 1, 20))
Else
Set rng = Union(rng, .Range(.Cells(lngIndex + 1, 1), .Cells(lngIndex + 1, 20)))
End If
End If
Next
If Not rng Is Nothing Then
rng.Copy Sheets("Abgleich").Range("A2")
Sheets("Abgleich").Range("V2").Resize(UBound(vntMark) + 1, 1) = _
Application.Transpose(vntMark)
End If
End With
Set rng = Nothing
Erase vntMark
lngC = 0
With Sheets("Materialliste")
For lngIndex = 1 To UBound(vnt2, 1)
If IsError(Application.Match(vnt2(lngIndex, 1), vnt1, 0)) Then
ReDim Preserve vntMark(lngC)
vntMark(lngC) = "Gel?scht"
lngC = lngC + 1
If rng Is Nothing Then
Set rng = .Range(.Cells(lngIndex + 1, 1), .Cells(lngIndex + 1, 20))
Else
Set rng = Union(rng, .Range(.Cells(lngIndex + 1, 1), .Cells(lngIndex + 1, 20)))
End If
End If
Next
If Not rng Is Nothing Then
rng.Copy Sheets("Abgleich").Range("A1").End(xlDown).Offset(1, 0)
Sheets("Abgleich").Range("V1").End(xlDown).Offset(1, 0).Resize(UBound(vntMark) + 1, 1) =   _
_
_
_
Application.Transpose(vntMark)
End If
End With
Set rng = Nothing
End Sub