Sub Макрос1()
    Dim n As Integer
    Set sd = CreateObject("Scripting.Dictionary")
    lr = Cells(Rows.Count, 1).End(xlUp).Row
    arr = Range("A2:B" & lr).Value
    ReDim arr_r(1 To UBound(arr), 1 To 1)
    For n = 1 To UBound(arr)
        If Not sd.Exists(arr(n, 1)) Then
            sd.Add arr(n, 1), n + 1
        Else
            sd(arr(n, 1)) = sd(arr(n, 1)) & ";" & n + 1
        End If
    Next
    For n = 1 To UBound(arr)
        arr_r(n, 1) = "=RANK(B" & n + 1 & ",$B$" & Split(sd(arr(n, 1)), ";")(0) & ":$B$" & Split(sd(arr(n, 1)), ";")(UBound(Split(sd(arr(n, 1)), ";"))) & ",0)"
    Next
    [c2].Resize(UBound(arr_r), 1) = arr_r
End Sub

Sub A_Z()
    Dim n As Integer, m As Integer
    Set sd = CreateObject("Scripting.Dictionary")
    Set sd_1 = CreateObject("Scripting.Dictionary")
    arr = Range("A2:B" & Cells(Rows.Count, 1).End(xlUp).Row).Value
    ReDim arr_r(1 To UBound(arr), 1 To 1)
    For n = 1 To UBound(arr)
        If Not sd.Exists(arr(n, 1)) Then
            Set sd(arr(n, 1)) = CreateObject("Scripting.Dictionary")
            Set sd_1(arr(n, 1)) = CreateObject("Scripting.Dictionary")
            sd(arr(n, 1)).Add arr(n, 2), 1
        Else
            sd(arr(n, 1))(arr(n, 2)) = sd(arr(n, 1))(arr(n, 2)) + 1
        End If
    Next
    For Each y In sd_1
        arr_2 = sd(y).Keys
        For i& = LBound(arr_2) To UBound(arr_2) - 1
            For j& = LBound(arr_2) To UBound(arr_2) - i - 1
                If arr_2(j) > arr_2(j + 1) Then Tmp = arr_2(j): arr_2(j) = arr_2(j + 1): arr_2(j + 1) = Tmp
            Next j
        Next i
        m = 1
        For Each y1 In arr_2
            sd_1(y).Add y1, m
            m = sd(y)(y1) + m
        Next
    Next
    For n = 1 To UBound(arr)
        arr_r(n, 1) = sd_1(arr(n, 1))(arr(n, 2))
        sd_1(arr(n, 1))(arr(n, 2)) = sd_1(arr(n, 1))(arr(n, 2)) + 1
    Next
    Range("C2").Resize(UBound(arr_r), 1).Clear
    Range("C2").Resize(UBound(arr_r), 1) = arr_r
End Sub

Sub Z_A()
Dim n As Integer, m As Integer
    Set sd = CreateObject("Scripting.Dictionary")
    Set sd_1 = CreateObject("Scripting.Dictionary")
    arr = Range("A2:B" & Cells(Rows.Count, 1).End(xlUp).Row).Value
    ReDim arr_r(1 To UBound(arr), 1 To 1)
    For n = 1 To UBound(arr)
        If Not sd.Exists(arr(n, 1)) Then
            Set sd(arr(n, 1)) = CreateObject("Scripting.Dictionary")
            Set sd_1(arr(n, 1)) = CreateObject("Scripting.Dictionary")
            sd(arr(n, 1)).Add arr(n, 2), 1
        Else
            sd(arr(n, 1))(arr(n, 2)) = sd(arr(n, 1))(arr(n, 2)) + 1
        End If
    Next
    For Each y In sd_1
        arr_2 = sd(y).Keys
        m = 0
        For i& = LBound(arr_2) To UBound(arr_2) - 1
            For j& = LBound(arr_2) To UBound(arr_2) - i - 1
                If arr_2(j) > arr_2(j + 1) Then Tmp = arr_2(j): arr_2(j) = arr_2(j + 1): arr_2(j + 1) = Tmp
            Next j
            m = m + sd(y)(arr_2(i))
        Next i
        m = m + sd(y)(arr_2(UBound(arr_2)))
        
        For n = LBound(arr_2) To UBound(arr_2)
            sd_1(y).Add arr_2(n), m
            m = m - sd(y)(arr_2(n))
        Next
    Next
    For n = 1 To UBound(arr)
        arr_r(n, 1) = sd_1(arr(n, 1))(arr(n, 2))
        sd_1(arr(n, 1))(arr(n, 2)) = sd_1(arr(n, 1))(arr(n, 2)) - 1
    Next
    Range("D2").Resize(UBound(arr_r), 1).Clear
    Range("D2").Resize(UBound(arr_r), 1) = arr_r
End Sub