Data list summary-2D array

Option Explicit

Sub Summary()
    Dim x, y, z, months, i&, ii&, lColD&, lColP&, lColQ&, lCol&, oDic As Object
    
' Place months in required order into an array (months)
    months = Array("April", "May", "June", "July", "August", "September", _
                "October", "November", "December", "January", "February", "March")

' Get the column numbers for Date, Product and Quantity
    lColD = Application.Match("Date", Sheet1.Rows(1), 0)
    lColP = Application.Match("Products", Sheet1.Rows(1), 0)
    lColQ = Application.Match("Quantity", Sheet1.Rows(1), 0)
    Set oDic = CreateObject("scripting.dictionary")
    
' Load all Input data into array x
    x = Sheet1.Cells(1).CurrentRegion
    
' Loop through array x and us scripting dictionary to get a liast of unique products
' Load that lis into array z
    With oDic
        For i = 2 To UBound(x, 1)
            If Not .exists(x(i, lColP)) Then .Add x(i, lColP), Nothing
        Next
        z = .keys
    End With
    
' Redim y to suit number of products (plus Header and Total rows)
    ReDim y(1 To oDic.Count + 2, 1 To 15)
    
' Load array y with required headers
    y(1, 1) = "S.No": y(1, 2) = "Products": y(1, 15) = "Product Totals"
    For i = 3 To 14
        y(1, i) = months(i - 3)
    Next
    
' Loop through array y and load with S.No and Product
    For i = 2 To UBound(y, 1)
        y(UBound(y, 1), 2) = "Monthly Totals"
        If i - 3 < UBound(z) Then y(i, 1) = i - 1: y(i, 2) = z(i - 2)
        
    ' Loop through array x and get Quantity for each Product
    ' Update Product and Monthly totals
        For ii = 2 To UBound(x, 1)
            If x(ii, lColP) = y(i, 2) Then
                lCol = Application.Match(MonthName(Month(x(ii, lColD)), 0), months, 0) + 2
                y(i, lCol) = y(i, lCol) + x(ii, lColQ)
                y(i, 15) = y(i, 15) + x(ii, lColQ)
                y(UBound(y, 1), lCol) = y(UBound(y, 1), lCol) + x(ii, lColQ)
                y(UBound(y, 1), 15) = y(UBound(y, 1), 15) + x(ii, lColQ)
            End If
        Next
    Next
    
' Load the contents of array y onto the Output sheet (after clear anything there)
' Add required formatting to Output data
    With Sheet2
        .UsedRange.Clear
        .[a1] = "Summary": .[a1].Font.Bold = 1
        With .[a2].Resize(UBound(y, 1), 15)
            .Value = y
            .Borders.Weight = 2
            .Columns(1).Font.Bold = 1
            .Columns(2).Font.Bold = 1
            .Columns(15).Font.Bold = 1
            .Rows(1).Font.Bold = 1
            .Rows(.Rows.Count).Font.Bold = 1
            .Columns.AutoFit
        End With
        .Activate
    End With
    
End Sub

Option Explicit
Sub testi()
    Dim a(), b(), i As Long, n As Long, t As Long, w, e, u
    Dim dic1 As Object, dic2 As Object
    Set dic1 = CreateObject("Scripting.Dictionary")
    dic1.CompareMode = vbTextCompare
    Set dic2 = CreateObject("Scripting.Dictionary")
    dic2.CompareMode = vbTextCompare
    With Sheet3
        a = .Range("a1").CurrentRegion.Resize(, 7).Value
    End With
    n = 1
    t = 1
    ReDim b(1 To UBound(a, 1), 1 To 14)
    For i = 2 To UBound(a, 1)
        If Not dic1.exists(Format(a(i, 1), "mmmm")) Then
            t = t + 1
            dic1.Add Format(a(i, 1), "mmmm"), Array(t, a(i, 7))
            b(1, t) = Format(a(i, 1), "mmmm")
        Else
            w = dic1(Format(a(i, 1), "mmmm"))
            w(1) = w(1) + a(i, 7)
            dic1(Format(a(i, 1), "mmmm")) = w
        End If
        If Not dic2.exists(a(i, 4)) Then
            n = n + 1
            dic2.Add a(i, 4), Array(n, a(i, 7))
            b(n, 1) = a(i, 4)
        Else
            u = dic2(a(i, 4))
            u(1) = u(1) + a(i, 7)
            dic2(a(i, 4)) = u
        End If
        b(dic2(a(i, 4))(0), dic1(Format(a(i, 1), "mmmm"))(0)) = b(dic2(a(i, 4))(0), dic1(Format(a(i, 1), "mmmm"))(0)) + a(i, 7)
    Next
    For Each e In dic1.keys
        w = dic1.Item(e)
        b(n + 1, w(0)) = w(1)
        b(n + 1, t + 1) = b(n + 1, t + 1) + w(1)
    Next
    For Each e In dic2.keys
        u = dic2.Item(e)
        b(u(0), t + 1) = u(1)
    Next
    With Sheet2
        .UsedRange.Clear
        With .Range("a1").Resize(n + 1, t + 1)
            .Value = b
            .Borders.Weight = 2
        End With
    End With
End Sub