Option Explicit

Sub stolbik_zaychik()
Dim r As Long, rw As Long, rww As Long, rws As Long

    r = 5: rww = 5: rws = Cells(Rows.Count, "b").End(xlUp).Row
    Do While r <= rws
        Do Until Trim(Cells(r, 2).Value) = ""
            rw = r
            Do While Cells(r, 2).Value = Cells(r + 1, 2).Value
                r = r + 1
            Loop
            Cells(rww, 7).Value = Cells(rw, 2).Value
            Cells(rww + 1, 7).Resize((r - rw + 1), 1).Value = Cells(rw, 3).Resize((r - rw + 1), 1).Value
            If (r - rw + 1) > 1 Then rww = (rww + 1) + (r - rw + 1) Else rww = (rww + 2)
            r = r + 1
        Loop
        r = r + 1
    Loop
End Sub

Sub unite()
    Dim o_dict As Object
    Set o_dict = CreateObject("Scripting.dictionary")
    Dim arr_in
    arr_in = Range("B5:C12").Value
    For i = LBound(arr_in) To UBound(arr_in)
        For n = LBound(arr_in, 2) To UBound(arr_in, 2)
            If arr_in(i, n) <> "" Then a = o_dict(arr_in(i, n))
        Next n
    Next i
    arr_out = o_dict.keys
    Range("E5").Resize(UBound(arr_out) + 1).Value = Application.Transpose(arr_out)
End Sub