Hallo! Hier mal eine Variante. Einiges musst du im Code ggf. mal noch anpassen. Ist getestet und sollte eigentlich funktionieren. Vg

Sub rang_ermitteln()

Dim ende As Long
Dim blatt As Object
Dim zeile As Long
Dim werte(3)
Dim rang(3)
Dim i As Long
Dim fertig As Boolean
Dim größter As Long
Dim kleinster As Long

Application.ScreenUpdating = False

'das blatt festlegen, wo sich alles abspielt - anpassen!!!!!
Set blatt = Worksheets(1)

'alle zeilen in spalte Aermitteln
ende = blatt.Cells(Rows.Count, 1).End(xlUp).Row

'jetzt durch alle Zeilen und rang ermitteln start ist in zeile 3 - anpassen!!!!!!
For zeile = 3 To ende
    'werte aus den Spalten ziehen
    For i = 1 To 3
        werte(i) = blatt.Cells(zeile, 3 + (i - 1) * 6)
    Next i
    
    'werte der ersten beiden vergleichen
    If werte(2) > werte(1) Then
        rang(2) = 1
        rang(1) = 2
        größter = 2
        kleinster = 1
    ElseIf werte(2) = werte(1) Then
        rang(2) = 1
        rang(1) = 1
        größter = 1
        kleinser = 1
    Else
        rang(2) = 2
        rang(1) = 1
        größter = 1
        kleinster = 2
    End If
    
    fertig = False
    
    'den dritten wert
    If werte(3) = werte(1) Then
        rang(3) = rang(1)
        fertig = True
    End If
    
    If werte(3) = werte(2) Then
        rang(3) = rang(2)
        fertig = True
    End If
    
    If fertig = False And werte(größter) < werte(3) Then
    'ist größer als der größte
        rang(3) = 1
        rang(2) = rang(2) + 1
        rang(1) = rang(1) + 1
        fertig = True
    End If
    
    If fertig = False And werte(kleinster) > werte(3) Then
    'ist kleiner als der kleinste
        rang(3) = rang(kleinster) + 1
        fertig = True
    End If
    
    'liegt dazwischen
    If fertg = False And werte(3) < werte(größter) And werte(3) > werte(kleinster) Then
        rang(3) = rang(kleinster)
        rang(kleinster) = rang(kleinster) + 1
    End If
    
    'rang eintragen, geht in Spalte 21 los
    
    For i = 1 To 3
        blatt.Cells(zeile, 20 + i) = rang(i)
    Next i
Next zeile

Application.ScreenUpdating = True

End Sub