Option Explicit

Sub Transform1C()
    CloseEmptyWb
    Dim arr As Variant
    arr = Intersect(Selection, ActiveSheet.UsedRange).Areas(1).Columns(1).Resize(, 2).Value
    
    Dim brr As Variant
    brr = GetFlatArray(arr)
    If IsEmpty(brr) Then Exit Sub
    PrintArray brr
End Sub

Private Sub PrintArray(arr As Variant)
    With Workbooks.Add(1)
        With .Sheets(1)
            With .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
                .Value = arr
                .Rows(1).Font.Bold = True
            End With
        End With
        .Saved = True
    End With
End Sub

Private Function GetFlatArray(arr As Variant) As Variant
    Dim dicX As Object
    Set dicX = CreateObject("Scripting.Dictionary")
    
    Dim dicY As Object
    Set dicY = CreateObject("Scripting.Dictionary")
    
    Dim ya As Long
    For ya = 1 To UBound(arr, 1)
        If IsSklad(arr(ya, 2)) Then
            If Not dicX.Exists(arr(ya, 1)) Then dicX.Item(arr(ya, 1)) = dicX.Count + 2
        Else
            If Not dicY.Exists(arr(ya, 1)) Then dicY.Item(arr(ya, 1)) = dicY.Count + 2
        End If
    Next
    
    If dicX.Count = 0 Then Exit Function
    If dicY.Count = 0 Then Exit Function
    
    Dim xb As Long
    Dim yb As Long
    Dim brr As Variant
    ReDim brr(1 To dicY.Items()(dicY.Count - 1), 1 To dicX.Items()(dicX.Count - 1))
    brr(1, 1) = "Продукция"
    For yb = 0 To dicY.Count - 1
        brr(dicY.Items()(yb), 1) = dicY.Keys()(yb)
    Next
    For yb = 0 To dicX.Count - 1
        brr(1, dicX.Items()(yb)) = dicX.Keys()(yb)
    Next
    
    
    For ya = 1 To UBound(arr, 1)
        yb = 0
        If IsSklad(arr(ya, 2)) Then
            xb = dicX.Item(arr(ya, 1))
        Else
            yb = dicY.Item(arr(ya, 1))
        End If
        If yb > 0 Then
            If xb > 0 Then
                If IsNumeric(arr(ya, 2)) Then
                    brr(yb, xb) = brr(yb, xb) + arr(ya, 2)
                End If
            End If
        End If
    Next
    
    GetFlatArray = brr
End Function

Private Function IsSklad(ByVal ss As String) As Boolean
    Select Case ss
    Case "", "Кол-во"
        IsSklad = True
    End Select
End Function

Private Sub CloseEmptyWb()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Path = "" Then wb.Close False
    Next
End Sub