Как произвести расчет по таблице разных значений?

[pritlex]

Как посчитать количество домов и жителей по каждой улице?
вот образец https://yadi.sk/i/UBrIowUpcUkU3
суть такая надо посчитать сколько домов по каждой улице и сколько жителей на каждой улице...
Помогите парни у меня тут 26524 строки я в истерике
Заранее спасибо))

[IgorGO]

предполагается что данные посортированы по колонке F, где улица-дом

Sub CalcHousePeople()
  Dim n As Long, i As Long, a(), u As String
  ReDim a(1 To Cells(Rows.Count, 6).End(xlUp).Row, 1 To 3)
  Range("G:I").ClearContents: a = Cells(1, 6).Resize(UBound(a), 3).Value
  a(1, 1) = "Улица": a(1, 2) = "Домов": a(1, 3) = "Жильцов":  n = 2
  u = Left(a(2, 1), InStr(a(2, 1), ",") - 1)
  a(n, 2) = Right(a(n, 1), Len(a(n, 1)) - Len(u) - 2) & Chr(9): a(n, 3) = 1: a(n, 1) = u
  For i = 3 To UBound(a)
    u = Left(Cells(i, 6), InStr(Cells(i, 6), ",") - 1)
    If u = a(n, 1) Then
      a(n, 3) = a(n, 3) + 1
      If InStr(a(n, 2), Right(a(i, 1), Len(a(i, 1)) - Len(u) - 2) & Chr(9)) = 0 Then _
        a(n, 2) = a(n, 2) & Right(a(i, 1), Len(a(i, 1)) - Len(u) - 2) & Chr(9)
    Else
      a(n, 2) = UBound(Split(a(n, 2), Chr(9)))
      n = n + 1
      a(n, 1) = u: a(n, 2) = Right(a(i, 1), Len(a(i, 1)) - Len(u) - 2) & Chr(9): a(n, 3) = 1
    End If
  Next
  a(n, 2) = UBound(Split(a(n, 2), Chr(9)))
  Cells(1, 7).Resize(n, 3).Value = a
End Sub

[Hugo121]

Посчитал.
Куда выводить - не придумал. Вернее без понятия...

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

Крч:

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

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

[SAS888]

Еще вариант, до "кучи":

Sub qq()
    Dim i As Long, j As Long, k As Long, a()
    Application.ScreenUpdating = False: Application.DisplayAlerts = False
    ReDim a(1 To Cells(Rows.Count, 6).End(xlUp).Row, 1 To 3)
    [F:F].TextToColumns Destination:=[G1], DataType:=xlDelimited, Comma:=True
    a(1, 1) = "Улица": a(1, 2) = "Домов": a(1, 3) = "Жильцов": i = 2: k = 2
    Do While Cells(i, 7) <> ""
        j = Application.CountIf([G:G], Cells(i, 7)): a(k, 1) = Cells(i, 7)
        With Range(Cells(i, 8), Cells(i + j - 1, 8))
            .RemoveDuplicates 1: a(k, 2) = Application.CountA(.Value)
        End With
        a(k, 3) = j: i = i + j: k = k + 1
    Loop
    [G:I].ClearContents: Cells(1, 7).Resize(k, 3).Value = a
End Sub

[pritlex]

где надо дописать чтоб в файл сохранило?