Zwei Dateien abgleichen

Sub compareSheets()
Dim objWB As Workbook
Dim vntSrc1 As Variant, vntSrc2 As Variant
Dim vntInBoth() As Variant, vntInFirstOnly() As Variant, vntInSecondOnly() As Variant
Dim vntIdentisch() As Variant, vntInFirst() As Variant, vntInSecond() As Variant
Dim vntZeileFirst() As Variant, vntZeileSecond() As Variant
Dim vntDataFirst As Variant, vntDataSecond As Variant
Dim bolIdentisch As Boolean, Spalte As Long
Dim lngIndex As Long, lngCBoth As Long, lngCFirst As Long, lngCSecond As Long
Dim vntRet As Variant, blnWasOpen As Boolean
Dim strFile1 As String, strFile2 As String
strFile1 = Application.GetOpenFilename("Excel Dateien (*.xls; *.xlsx; *.xlsm)," & _
"*.xls; *.xlsx; *.xlsm", Title:="Bitte erste Datei wählen")
If strFile1 = CStr(False) Then Exit Sub
strFile2 = Application.GetOpenFilename("Excel Dateien (*.xls; *.xlsx; *.xlsm)," & _
"*.xls; *.xlsx; *.xlsm", Title:="Bitte zweite Datei wählen")
If strFile2 = CStr(False) Then Exit Sub
On Error GoTo Errexit
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
For Each objWB In Workbooks
If objWB.FullName = strFile1 Then
blnWasOpen = True
Exit For
End If
Next
If objWB Is Nothing Then Set objWB = Workbooks.Open(strFile1)
With objWB.Sheets("Tabelle1")
vntSrc1 = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
vntDataFirst = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, _
.Cells(1, .Columns.Count).End(xlToLeft).Column))
End With
If Not blnWasOpen Then objWB.Close False
Set objWB = Nothing
blnWasOpen = False
For Each objWB In Workbooks
If objWB.FullName = strFile2 Then
blnWasOpen = True
Exit For
End If
Next
If objWB Is Nothing Then Set objWB = Workbooks.Open(strFile2)
With objWB.Sheets("Tabelle1")
vntSrc2 = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
vntDataSecond = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, _
.Cells(1, .Columns.Count).End(xlToLeft).Column))
End With
If Not blnWasOpen Then objWB.Close False
ReDim vntInBoth(0)
vntInBoth(0) = "In beiden Dateien"
lngCBoth = 1
ReDim vntIdentisch(0)
vntIdentisch(0) = "Identisch"
ReDim vntInFirst(0)
vntInFirst(0) = "Zeile " & strFile1
ReDim vntInSecond(0)
vntInSecond(0) = "Zeile " & strFile2
ReDim vntInFirstOnly(0)
vntInFirstOnly(0) = "Nur in Datei " & strFile1
lngCFirst = 1
ReDim vntZeileFirst(0)
vntZeileFirst(0) = "Zeile"
ReDim vntInSecondOnly(0)
vntInSecondOnly(0) = "Nur in Datei " & strFile2
lngCSecond = 1
ReDim vntZeileSecond(0)
vntZeileSecond(0) = "Zeile"
For lngIndex = 1 To UBound(vntSrc1, 1)
vntRet = Application.Match(vntSrc1(lngIndex, 1), vntSrc2, 0)
If IsNumeric(vntRet) Then
ReDim Preserve vntInBoth(lngCBoth)
vntInBoth(lngCBoth) = vntSrc1(lngIndex, 1)
bolIdentisch = True
'Vergleich der Werte in den Spalten der Zeilen
For Spalte = LBound(vntDataFirst, 2) To UBound(vntDataFirst, 2)
If vntDataFirst(lngIndex, Spalte)  vntDataSecond(vntRet, Spalte) Then
bolIdentisch = False
Exit For
End If
Next
ReDim Preserve vntIdentisch(lngCBoth)
vntIdentisch(lngCBoth) = bolIdentisch
ReDim Preserve vntInFirst(lngCBoth)
vntInFirst(lngCBoth) = lngIndex + 1
ReDim Preserve vntInSecond(lngCBoth)
vntInSecond(lngCBoth) = vntRet + 1
lngCBoth = lngCBoth + 1
Else
ReDim Preserve vntInFirstOnly(lngCFirst)
vntInFirstOnly(lngCFirst) = vntSrc1(lngIndex, 1)
ReDim Preserve vntZeileFirst(lngCFirst)
vntZeileFirst(lngCFirst) = lngIndex + 1
lngCFirst = lngCFirst + 1
End If
Next
For lngIndex = 1 To UBound(vntSrc2, 1)
vntRet = Application.Match(vntSrc2(lngIndex, 1), vntSrc1, 0)
If Not IsNumeric(vntRet) Then
ReDim Preserve vntInSecondOnly(lngCSecond)
vntInSecondOnly(lngCSecond) = vntSrc2(lngIndex, 1)
ReDim Preserve vntZeileSecond(lngCSecond)
vntZeileSecond(lngCSecond) = lngIndex + 1
lngCSecond = lngCSecond + 1
End If
Next
ThisWorkbook.Worksheets.Add after:=ActiveSheet
With ActiveSheet
.Name = "Vergleich_" & Format(Now, "yyyymmdd-hhMMss")
.Range("A1").Resize(UBound(vntInBoth) + 1, 1) = Application.Transpose(vntInBoth)
.Range("B1").Resize(UBound(vntIdentisch) + 1, 1) = Application.Transpose(vntIdentisch)
.Range("C1").Resize(UBound(vntInFirst) + 1, 1) = Application.Transpose(vntInFirst)
.Range("D1").Resize(UBound(vntInSecond) + 1, 1) = Application.Transpose(vntInSecond)
.Range("E1").Resize(UBound(vntInFirstOnly) + 1, 1) = Application.Transpose(vntInFirstOnly)
.Range("F1").Resize(UBound(vntZeileFirst) + 1, 1) = Application.Transpose(vntZeileFirst)
.Range("G1").Resize(UBound(vntInSecondOnly) + 1, 1) = Application.Transpose(vntInSecondOnly) _
_
.Range("H1").Resize(UBound(vntZeileSecond) + 1, 1) = Application.Transpose(vntZeileSecond)
.Rows(1).Font.Bold = True
.Columns.AutoFit
End With
Errexit:
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Set objWB = Nothing
End Sub