Hallo! Also habe nochmal gebastelt und ergänzt. Jetzt sollte es auf Blatt 1 egal sein, ob die sortiert ist oder nicht. Es sucht sich alle raus. Aber nochmal als Frage: Nr und Bez. waren immer gleich und die restlichen Inhalt konnte sich ändern. Wie gesagt, probiere es mal damit. Gruß

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   'fertig
            ' es wird davon ausgegangen, dass die Werte untereinanderstehen, nur inBlatt zwei wird gesucht
            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 'fertig
            ' bei zwei zeilen in Blatt 1 und zwei in Blatt2 wird der Wert mit den meisten Übereinstimmunen genommen
        
            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))
            
            'prüfen wer die meisten Übereinstimmungen hat, der wird genommen
            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   'fertig
            'da nix, wird am Ende gleb markiert
            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 'fertig
            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 ' Prüfung ob x steht
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