Option Explicit
Sub vergleichen()
Dim ende As Long
Dim ende2 As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim anzahl1 As Long
Dim anzahl2 As Long
Dim zeile1 As Long
Dim zeile12 As Long
Dim zeile2 As Long
Dim zeile22 As Long
Dim eins As Object
Dim zwei As Object
Dim inhalt11
Dim inhalt12
Dim inhalt21
Dim inhalt22
Dim ident1 As Long
Dim ident2 As Long
Application.ScreenUpdating = False
Set eins = Worksheets(1)
Set zwei = Worksheets(2)
zwei.UsedRange.Interior.ColorIndex = xlNone
ende = eins.Cells(Rows.Count, 1).End(xlUp).Row
ende2 = zwei.Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To ende
If eins.Cells(i, 27) = "x" Then
Else
anzahl1 = Application.WorksheetFunction.CountIf(eins.Columns(1), eins.Cells(i, 1))
anzahl2 = Application.WorksheetFunction.CountIf(zwei.Columns(1), eins.Cells(i, 1))
Select Case anzahl1 & anzahl2
Case 22
inhalt11 = eins.Range(eins.Cells(i, 1), eins.Cells(i, 26))
zeile1 = i + Application.WorksheetFunction.Match(eins.Cells(i, 1), eins.Range(eins.Cells(i + 1, 1), eins.Cells(ende, 1)), 0)
inhalt12 = eins.Range(eins.Cells(zeile1, 1), eins.Cells(zeile1, 26))
zeile2 = Application.WorksheetFunction.Match(eins.Cells(i, 1), zwei.Columns(1), 0)
inhalt21 = zwei.Range(zwei.Cells(zeile2, 1), zwei.Cells(zeile2, 26))
zeile22 = zeile2 + Application.WorksheetFunction.Match(eins.Cells(i, 1), zwei.Range(zwei.Cells(zeile2 + 1, 1), zwei.Cells(ende2, 1)), 0)
inhalt22 = zwei.Range(zwei.Cells(zeile22, 1), zwei.Cells(zeile22, 26))
For j = anzahl1 To 1 Step -1
If j = 1 Then
zeile22 = zeile2
zeile1 = i
End If
For k = 1 To 26
If zwei.Cells(zeile22, k) <> eins.Cells(zeile1, k) Then zwei.Cells(zeile22, k).Interior.ColorIndex = 6
Next k
zwei.Cells(zeile22, 27) = "x"
eins.Cells(zeile1, 27) = "x"
Next j
eins.Cells(i, 27) = "x"
eins.Cells(zeile1, 27) = "x"
Case 11
zeile2 = Application.WorksheetFunction.Match(eins.Cells(i, 1), zwei.Columns(1), 0)
For k = 1 To 26
If zwei.Cells(zeile2, k) <> eins.Cells(i, k) Then zwei.Cells(zeile2, k).Interior.ColorIndex = 6
Next k
zwei.Cells(zeile2, 27) = "x"
eins.Cells(i, 27) = "x"
Case 21
inhalt11 = eins.Range(eins.Cells(i, 1), eins.Cells(i, 26))
zeile1 = i + Application.WorksheetFunction.Match(eins.Cells(i, 1), eins.Range(eins.Cells(i + 1, 1), eins.Cells(ende, 1)), 0)
inhalt12 = eins.Range(eins.Cells(zeile1, 1), eins.Cells(zeile1, 26))
zeile2 = Application.WorksheetFunction.Match(eins.Cells(i, 1), zwei.Columns(1), 0)
inhalt21 = zwei.Range(zwei.Cells(zeile2, 1), zwei.Cells(zeile2, 26))
ident1 = 0
ident2 = 0
For k = 1 To 26
If inhalt11(1, k) = inhalt21(1, k) Then ident1 = ident1 + 1
If inhalt12(1, k) = inhalt21(1, k) Then ident2 = ident2 + 1
Next k
j = i
If ident1 < ident2 Then j = zeile1
For k = 1 To 26
If zwei.Cells(zeile2, k) <> eins.Cells(j, k) Then zwei.Cells(zeile2, k).Interior.ColorIndex = 6
Next k
zwei.Cells(zeile2, 27) = "x"
eins.Cells(i, 27) = "x"
eins.Cells(zeile1, 27) = "x"
Case 20, 10
eins.Cells(i, 27) = "x"
If anzahl1 = 2 Then
zeile1 = i + Application.WorksheetFunction.Match(eins.Cells(i, 1), eins.Range(eins.Cells(i + 1, 1), eins.Cells(ende, 1)), 0)
eins.Cells(zeile1, 27) = "x"
End If
Case 12
inhalt11 = eins.Range(eins.Cells(i, 1), eins.Cells(i, 26))
zeile2 = Application.WorksheetFunction.Match(eins.Cells(i, 1), zwei.Columns(1), 0)
inhalt21 = zwei.Range(zwei.Cells(zeile2, 1), zwei.Cells(zeile2, 26))
zeile22 = zeile2 + Application.WorksheetFunction.Match(eins.Cells(i, 1), zwei.Range(zwei.Cells(zeile2 + 1, 1), zwei.Cells(ende2, 1)), 0)
inhalt22 = zwei.Range(zwei.Cells(zeile22, 1), zwei.Cells(zeile22, 26))
ident1 = 0
ident2 = 0
For k = 1 To 26
If inhalt11(1, k) = inhalt21(1, k) Then ident1 = ident1 + 1
If inhalt11(1, k) = inhalt22(1, k) Then ident2 = ident2 + 1
Next k
If ident1 < ident2 Then zeile2 = zeile22
For k = 1 To 26
If zwei.Cells(zeile2, k) <> eins.Cells(i, k) Then zwei.Cells(zeile2, k).Interior.ColorIndex = 6
Next k
zwei.Cells(zeile2, 27) = "x"
eins.Cells(i, 27) = "x"
Case Else
End Select
End If
Next i
For i = 1 To ende2
If zwei.Cells(i, 27) <> "x" Then zwei.Range(zwei.Cells(i, 1), zwei.Cells(i, 26)).Interior.ColorIndex = 6
Next i
zwei.Columns("AA").ClearContents
eins.Columns("AA").ClearContents
Set eins = Nothing
Set zwei = Nothing
Application.ScreenUpdating = True
End Sub