Sub Button1_Click()

Dim i As Integer
Dim str As String
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If IsNumeric(Cells(i, 1)) = False Then
str = str & Cells(i, 1)
Else
Cells(i, 3) = Cells(i, 1)
Cells(i, 2) = str
str = ""
End If
Next i

End Sub

Sub Ассортимент()
    Dim sh As Worksheet
    Set sh = ActiveSheet
    Dim arr As Variant
    Dim y As Long
    With sh
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = .Range(.Cells(1, 1), .Cells(y, 3))
    End With
    
    Dim d As Double
    Dim brr As Variant
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Dim u As Long
    u = 2
    For y = 2 To UBound(arr, 1)
        arr(y, 2) = Empty
        arr(y, 3) = Empty
        If IsNumeric(arr(y, 1)) Then
            If Not dic Is Nothing Then
                If dic.Count > 0 Then
                    arr(u, 2) = Join(dic.Items(), " ")
                End If
            End If
            arr(u, 3) = arr(y, 1)
            
            'd = arr(y, 1)
            Set dic = CreateObject("Scripting.Dictionary")
            u = y + 1
        Else
            If Not dic Is Nothing Then dic.Item(dic.Count) = arr(y, 1)
        End If
    Next
    sh.Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End Sub