Sub Dictionary_Coll()
'' Author:  boa
'' Written: 10.10.2018
'' Edited:
'  Description:
'  Справочный материал: 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 MyArray As Range, NewMyArray, a, Dic As Object
    
    On Error Resume Next
    Set MyArray = Application.InputBox("Только одна колонка с адресами." & vbLf & _
                    "Квартиры должны быть в соседней колонке справа от выделенного.", _
                    "Выберите диапазон с адресами", , , , , , 8) '[m2:m5000]    ' массив с адресами
    If Err.Number > 0 Then Exit Sub
    
    Dim RunTimes As Date: RunTimes = Time
    Dim Start!:         Start = Timer

''   для раннего связывания требуется подключение
''   Tools - References... "Microsoft Scripting Runtime"
'    Set Dic = New Dictionary
    
    Set Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = vbTextCompare   'Что бы сделать ключить не чуствительными к регистру.
    
    For Each a In MyArray
        If Dic.Exists(CStr(a)) Then
            Dic.Item(CStr(a)) = Dic.Item(CStr(a)) & "|" & a.Offset(, 1).Value
        Else
            Dic.Add CStr(a), a.Offset(, 1).Value
        End If
    Next a
    
    For Each a In Dic.keys
        Dic.Item(a) = SearchNumKv(SortedRezult(Split(Dic.Item(a), "|")))
        If Len(Dic.Item(a)) = 0 Then Dic.Remove a   'что бы выводить в результат только строки со значениями. Можно закомментировать.
    Next
    
    NewMyArray = Application.Transpose(Array(Dic.keys, Dic.Items))
    
    With Workbooks.Add(xlWBATWorksheet).Worksheets(1)
        .Range(.Cells(1, 1), .Cells(Dic.Count, 2)) = NewMyArray
        .Columns(1).AutoFit
    End With
    Debug.Print "Затрачено: " & Format(Timer - Start, "#0.0") & " сек."
    'MsgBox "Затрачено: " & Format(Time - RunTimes, "hh:mm:ss")
End Sub

Private Function SortedRezult(Massiv As Variant)
Dim n&, i&
Dim Tmp1 As Variant
Dim Tmp2 As Variant
    On Error Resume Next
    For i = LBound(Massiv) To UBound(Massiv) Step 1
        Tmp1 = Val(Massiv(i))
        For n = i To UBound(Massiv)
            If Val(Massiv(n)) < Tmp1 Then
                Tmp1 = Massiv(n): Tmp2 = Massiv(i)
                Massiv(i) = Tmp1: Massiv(n) = Tmp2
            End If
        Next n
    Next i
    SortedRezult = Massiv
End Function

Private Function SearchNumKv(Massiv As Variant)
    Dim i&, j&, sVal$
    For i = 1 To Val(Massiv(UBound(Massiv)))
        For j = LBound(Massiv) To UBound(Massiv)
            If i = Val(Massiv(j)) Then Exit For
        Next
        If j > UBound(Massiv) Then sVal = sVal & ", " & i
    Next
    SearchNumKv = Mid(sVal, 3)
End Function