Sub Макрос1()
    Dim n As Long, m As Long, k As Long, i As Long, sd As Object, lr As Long, lc As Long, ln As Long
    Set sd = CreateObject("Scripting.Dictionary")
    Set sd_t = CreateObject("Scripting.Dictionary")
    lr = Cells(Rows.Count, 2).End(xlUp).Row
    lc = Cells(2, Columns.Count).End(xlToLeft).Column
    arr = ActiveSheet.Range(Cells(1, 1), Cells(lr, lc))
    ln = 0
    For m = 1 To UBound(arr, 2)
        If arr(1, m) = "Товар" Then ln = m
        If ln > 0 Then
            sd_t.Add arr(2, m), 0
        End If
    Next
    k = 0
    For n = 3 To UBound(arr)
        If Not sd.Exists(arr(n, 2)) Then Set sd(arr(n, 2)) = CreateObject("Scripting.Dictionary")
        For m = ln To UBound(arr, 2)
            If arr(n, m) <> "" Then
                If sd_t(arr(2, m)) = 0 Then sd_t(arr(2, m)) = 1: i = i + 1
                If Not sd(arr(n, 2)).Exists(arr(2, m)) Then
                    sd(arr(n, 2)).Add arr(2, m), arr(n, m)
                Else
                    sd(arr(n, 2))(arr(2, m)) = sd(arr(n, 2))(arr(2, m)) + arr(n, m)
                End If
            End If
        Next
        If sd(arr(n, 2)).Count > 0 Then
            k = k + 1
        End If
    Next
    ReDim arr_rez(1 To k + 1, 1 To i + 1)
    m = 2
    arr_rez(1, 1) = "ФИО"
    For Each y In sd_t
        If sd_t(y) = 1 Then
            arr_rez(1, m) = y
            sd_t(y) = m
            m = m + 1
        End If
    Next
    n = 2
    For Each y In sd
        If sd(y).Count > 0 Then
            arr_rez(n, 1) = y
            For Each y1 In sd(y)
                m = sd_t(y1)
                arr_rez(n, m) = sd(y)(y1)
            Next
            n = n + 1
        End If
    Next
    Worksheets("Результат").Select
    Worksheets("Результат").UsedRange.Clear
    Worksheets("Результат").Cells(1, 1).Resize(UBound(arr_rez), UBound(arr_rez, 2)) = arr_rez
End Sub