Public Sub Перебрать()
    Dim arr, arr1, arr2, arr3, x, y, lr As Long, i As Long, n As Integer
    Set sd = CreateObject("Scripting.Dictionary")
    lr = Cells(Rows.Count, 9).End(xlUp).Row
    arr = Range("I2:I" & lr).Value
    For i = 1 To UBound(arr)
        arr1 = Split(arr(i, 1), ";")
        For n = 0 To UBound(arr1)
            If arr1(n) <> "" Then
                arr2 = Split(arr1(n), "~")
                arr3 = Split(arr2(UBound(arr2)), ".")
                If UBound(arr2) = 0 Then arr2(0) = arr3(0): arr3(0) = "null"
                If Not sd.Exists(Trim(arr2(0))) Then Set sd(Trim(arr2(0))) = CreateObject("Scripting.Dictionary")
                If Not sd(Trim(arr2(0))).Exists(arr3(0)) Then Set sd(Trim(arr2(0)))(arr3(0)) = CreateObject("System.Collections.ArrayList")
                If Not sd(Trim(arr2(0)))(arr3(0)).contains(CInt(arr3(1))) Then sd(Trim(arr2(0)))(arr3(0)).Add CInt(arr3(1)) ', arr3(1)
            End If
        Next n
        For Each y In sd
            For Each x In sd(y)
                sd(y)(x).Sort
                If x = "null" Then
                    sd(y).Item(x) = "." & Join(sd(y)(x).toarray, ", ")
                Else
                    sd(y).Item(x) = "~" & x & "." & Join(sd(y)(x).toarray, ", ")
                End If
            Next
            sd(y) = y & Join(sd(y).Items, ", ")
        Next
        arr(i, 1) = Join(sd.Items, "; ")
        sd.RemoveAll
    Next
    Range("K2:K" & lr) = arr
End Sub