Hallo!

Also hier mal ein neuer Versuch. :-D Da es ja ein paar Spezialfälle gibt, musste ich da mal was festlegen. Also wenn in Blatt1 ein Eintrag mit Nr 123 ist und in Blatt2 zwei Einträge, wird der Eintrag mit den meisten Übereinstimmungen als alter Wert interpretiert und der zweite als neu eingefügte Zeile. Ähnlich wenn Blatt1 zwei Werte hat und Blatt 2 einen Wert. Auch hier gilt der Wert mit den meisten Übereinstimmungen als der richtige, der verglichen wird.

Wenn jeweils gleich viele Elemente vorkommen (2 in Blatt1 und Blatt2 bzw. 1 in Blatt1 und Blatt2) gehe ich davon aus, dass die Reihenfolge so ist, wie im Blatt eins. Die Werte im Blatt 2 haben also nicht die Zeile getauscht (letzte Frage von gestern, am Bsp. der Datumänderung).

Schaue mal bitte, ob das so wie gewünscht ist. Ansonsten können wir das auch noch ändern. Viele Grüße

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 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
    
    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, 11
            ' 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 j = 1 To anzahl1
                
                If j = 2 Then zeile2 = zeile2 + Application.WorksheetFunction.Match(eins.Cells(i + 1, 1), zwei.Range(zwei.Cells(zeile2 + 1, 1), zwei.Cells(ende2, 1)), 0)
            
                For k = 1 To 26
                    If zwei.Cells(zeile2, k) <> eins.Cells(i + j - 1, k) Then zwei.Cells(zeile2, k).Interior.ColorIndex = 6
                Next k
                
                zwei.Cells(zeile2, 27) = "x"
                
            Next j
            
        Case 21
            ' 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))
            inhalt12 = eins.Range(eins.Cells(i + 1, 1), eins.Cells(i + 1, 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 = 2
            If ident1 > ident2 Then j = 1
            
            For k = 1 To 26
                If zwei.Cells(zeile2, k) <> eins.Cells(i + j - 1, k) Then zwei.Cells(zeile2, k).Interior.ColorIndex = 6
            Next k
        
            zwei.Cells(zeile2, 27) = "x"
            
        Case 20, 10
            'da nix, wird am Ende gleb markiert
            
        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"
            
        Case Else

    End Select
    
    i = i + anzahl1 - 1
    
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

Set eins = Nothing
Set zwei = Nothing

Application.ScreenUpdating = True

End Sub