Ranking the rows without sorting

[MickG]

Try this:-

Sub RK()
Dim Rng As Range, Dn As Range, n As Long, c As Long
Set Rng = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))
ReDim ray(1 To Application.Max(Rng))
For Each Dn In Rng
    ray(Dn.Value) = ray(Dn.Value) & IIf(ray(Dn.Value) = "", Dn.Address, "," & Dn.Address)
Next Dn
For n = UBound(ray) To 1 Step -1
    If ray(n) <> "" Then
        c = c + 1
        For Each Dn In Range(ray(n)).Areas
            Range(Dn.Address).Offset(, 1).Value = c
        Next Dn
    End If
Next n
End Sub