Calcul de position en fonction du rang, avec des égalités

Option Explicit

Function CalculRang(maPlage As Range, Rang As Integer)
Dim temp(), tb(), j As Long, k As Long

    For j = 1 To maPlage.Columns.Count
        If k > 0 Then
            If Not Exist(temp(), maPlage.Cells(1, j).Value) Then
                k = k + 1: ReDim Preserve temp(1 To 2, 1 To k)
                temp(1, k) = maPlage.Cells(1, j).Value
                temp(2, k) = maPlage.Cells(1, j).Column
            End If
        Else
            k = k + 1: ReDim Preserve temp(1 To 2, 1 To k)
            temp(1, k) = maPlage.Cells(1, j).Value
            temp(2, k) = maPlage.Cells(1, j).Column
        End If
    Next j
    tb = Application.Transpose(temp)
    Call Quick(tb, LBound(tb), UBound(tb))
    CalculRang = tb(Rang, 2)
End Function

'sources : http://boisgontierjacques.free.fr/
Sub Quick(a, gauc, droi) ' Quick sort
Dim ref, g, d, temp
ref = a((gauc + droi) \ 2, 1)
g = gauc: d = droi
Do
   Do While a(g, 1) < ref: g = g + 1: Loop
   Do While ref < a(d, 1): d = d - 1: Loop
   If g <= d Then
      temp = a(g, 1): a(g, 1) = a(d, 1): a(d, 1) = temp
      temp = a(g, 2): a(g, 2) = a(d, 2): a(d, 2) = temp
      g = g + 1: d = d - 1
   End If
Loop While g <= d
If g < droi Then Call Quick(a, g, droi)
If gauc < d Then Call Quick(a, gauc, d)
End Sub

Function Exist(tb(), maVal) As Boolean
Dim i As Long
For i = LBound(tb, 2) To UBound(tb, 2)
    If tb(1, i) = maVal Then Exist = True: Exit Function
Next
Exist = False
End Function

=CalculRang(A2:F2;3)

=CalculRang(A2:F2;LIGNE()-1)

=CalculRang(I$21:P$21;LIGNE()-20)