Sub Main()
    Dim dic As Object
    Set dic = GetDic()
    
    Dim arr As Variant
    arr = GetArr(dic)
    
    Sheets("Лист1").Range("F2").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End Sub
'
Function GetDic() As Object
    Dim d As Object
    Set d = CreateObject("Scripting.Dictionary")
    
    With ActiveSheet
        Dim y As Long
        Dim a As Variant
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        a = .Range(.Cells(2, 1), .Cells(y, 4))
    End With
    
    Dim s As String
    For y = 1 To UBound(a, 1)
        If Not d.Exists(a(y, 1)) Then
            Set d.Item(a(y, 1)) = CreateObject("Scripting.Dictionary")
        End If
        s = Join(Array("Товар (", a(y, 2), ") (", a(y, 3), ") продаётся по цене (", a(y, 4), ")"), "")
        d.Item(a(y, 1)).Item(s) = 0
    Next
    
    Set GetDic = d
End Function
'
Function GetArr(dic As Object) As Variant
    Dim a As Variant
    If dic.Count = 0 Then
        ReDim a(1 To 1, 1 To 2)
    Else
        ReDim a(1 To dic.Count, 1 To 2)
        Dim y As Long
        For y = 1 To UBound(a, 1)
            a(y, 1) = dic.Keys()(y - 1)
            a(y, 2) = Join(dic.Items()(y - 1).Keys(), vbCrLf)
            
        Next
    End If
    GetArr = a
End Function