This will show equal places as "2=" etc.
Option Explicit
Sub Ranks()
    Dim r As Range, c As Range
    Dim s As Long, i As Long, k As Long
    Dim FA As String


    Set r = Cells.Find("Score")
    Set r = Range(r(2), r(2).End(xlDown))
    s = Application.Max(r)
    i = 1
    For s = Application.Max(r) To 1 Step -1
        k = 0
        With r
            Set c = .Find(s, lookat:=xlWhole)
            If Not c Is Nothing Then
                FA = c.Address
                Do
                    k = k + 1
                    Set c = .FindNext(c)
                Loop Until c.Address = FA
                
                Set c = .Find(s, lookat:=xlWhole)
                FA = c.Address
                Do
                    If k > 1 Then
                        c.Offset(, 1) = i & "="
                    Else
                        c.Offset(, 1) = i
                    End If
                    Set c = .FindNext(c)
                Loop Until c.Address = FA
            End If
        End With
        i = i + k
    Next s
End Sub