Option Explicit

Sub tt()    'коллекция в словаре
    Dim a, i&, t$, tt$, ttt$, DicD As Object, DicZ As Object
    Dim el

    On Error Resume Next

    a = Range("F3", Cells(Rows.Count, "B").End(xlUp)).Value

    Set DicD = CreateObject("Scripting.Dictionary"): DicD.CompareMode = 1
    Set DicZ = CreateObject("Scripting.Dictionary"): DicZ.CompareMode = 1

    For i = 1 To UBound(a)
        t = Split(a(i, 5), ":")(0)
        If Not DicD.exists(t) Then DicD.Add t, New Collection
        If Not DicZ.exists(t) Then DicZ.Add t, New Collection
        tt = Split(a(i, 5), ":")(1)
        ttt = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4)
        DicD.Item(t).Add tt, tt
        DicZ.Item(t).Add ttt, ttt
    Next

    For Each el In DicD.keys
        MsgBox "На улице " & el & " домов " & DicD.Item(el).Count
        MsgBox "На улице " & el & " жителей " & DicZ.Item(el).Count
    Next

End Sub

 

Option Explicit

Sub tt()    'коллекция в словаре
    Dim a, i&, t$, tt$, ttt$, el
    a = Range("F3", Cells(Rows.Count, "B").End(xlUp)).Value

    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1

        On Error Resume Next: For i = 1 To UBound(a)
            t = Split(a(i, 5), ":")(0)
            If Not .exists(t) Then .Add t, Array(New Collection, New Collection)
            tt = Split(a(i, 5), ":")(1): ttt = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4)
            .Item(t)(0).Add tt, tt: .Item(t)(1).Add ttt, ttt
        Next: On Error GoTo 0

        ReDim a(1 To .Count + 1, 1 To 3): i = 1
        a(i, 1) = "Улица": a(i, 2) = "Домов": a(i, 3) = "Жителей"
        For Each el In .keys
            i = i + 1
            a(i, 1) = el: a(i, 2) = .Item(el)(0).Count: a(i, 3) = .Item(el)(1).Count
        Next
    End With

    Workbooks.Add(1).Sheets(1).Cells(1).Resize(i, 3) = a
End Sub