'' Author:  boa
'' Written: 03.12.2018
Option Explicit

Function MyRank(d As Date, r As Range)
Dim MyArr, i&
If d = 0 Then MyRank = "": Exit Function
    MyArr = Dictionary_(r)
    For i = 1 To UBound(MyArr)
        If MyArr(i, 1) = d Then MyRank = i: Exit Function
    Next
End Function

Function Dictionary_(MyArray As Range)
'  Справочный материал: https://www.osp.ru/winitpro/2006/07/3643019/
                       'http://perfect-excel.ru/publ/excel/makrosy_i_programmy_vba/ischerpyvajushhee_opisanie_obekta_dictionary/7-1-0-101
    
    Dim a, Dic As Object
'    Dim MyArray
    
''   для раннего связывания требуется подключение
''   Tools - References... "Microsoft Scripting Runtime"
'    Set Dic = New Dictionary
    
    Set Dic = CreateObject("Scripting.Dictionary")
'    With ActiveWorkbook.ActiveSheet: MyArray = .Range(.Cells(3, 2), .Cells(.Rows.Count, 2).End(xlUp)): End With
    
    On Error Resume Next    'что бы не останавливалось на ошибке
    For Each a In MyArray
        If a <> "" Then Dic.Add CStr(a), CDate(a)                    'добавление
    Next a
        
    Set Dic = SortKeysByDict(Dic)
    Dictionary_ = Application.Transpose(Dic.Items)
End Function

Function SortKeysByDict(dctList As Object) As Object
'функция сортировки словаря
    Dim arrTemp() As Variant
    Dim curKey As Variant
    Dim iX&, iY&
    
    'Only sort if more than one item in the dict
    If dctList.Count > 1 Then

        'Populate the array
        ReDim arrTemp(dctList.Count)
        iX = 0
        For Each curKey In dctList
            arrTemp(iX) = curKey
            iX = iX + 1
        Next
        'Do the sort in the array
        For iX = 0 To (dctList.Count - 2)
            For iY = (iX + 1) To (dctList.Count - 1)
                If arrTemp(iX) > arrTemp(iY) Then
                    curKey = arrTemp(iY)
                    arrTemp(iY) = arrTemp(iX)
                    arrTemp(iX) = curKey
                End If
            Next
        Next
        'Create the new dictionary
        Dim d As Object: Set d = CreateObject("Scripting.Dictionary")
        For iX = 0 To (dctList.Count - 1)
            d(arrTemp(iX)) = dctList(arrTemp(iX))
        Next
        Set SortKeysByDict = d
    Else
        Set SortKeysByDict = dctList
    End If
End Function