How to use loop to SUM categories? - excel

Question

I am trying to use a loop with vba to sum values from one worksheet to another. I am struggling with writing my code to match values from Sheet 4 and if the value matches then sum the categories from Sheet 1, if not then skip to the next office. I would also like to exclude certain categories from being included in the SUM loop for example, exclude "Book". Currently my macro is writing to Sheet3. Here is my code:
Option Explicit
Sub test()
Dim a, i As Long, ii As Long, dic As Object
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = 1
a = Sheets("sheet1").Cells(1).CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(a, 1)
If Not dic.Exists(a(i, 1)) Then dic(a(i, 2)) = dic.Count + 2
If Not .Exists(a(i, 1)) Then
Set .Item(a(i, 1)) = CreateObject("Scripting.Dictionary")
.Item(a(i, 1)).CompareMode = 1
End If
.Item(a(i, 1))(a(i, 2)) = .Item(a(i, 1))(a(i, 2)) + a(i, 3)
Next
ReDim a(1 To .Count + 1, 1 To dic.Count + 1)
a(1, 1) = Sheets("sheet1").[a1]
For i = 0 To dic.Count - 1
a(1, i + 2) = dic.Keys()(i)
Next
For i = 0 To .Count - 1
a(i + 2, 1) = .Keys()(i)
For ii = 2 To UBound(a, 2)
a(i + 2, ii) = .items()(i)(a(1, ii)) + 0
Next
Next
End With
With Sheets("sheet3").Cells(1).Resize(UBound(a, 1), UBound(a, 2))
.EntireColumn.ClearContents
Sheets("sheet1").[a1].Copy .Rows(1)
.Value = a: .Columns.AutoFit: .Parent.Activate
End With
End Sub
This is how the data looks
and this is the output that is desired

Answer 1

In this example, we will use arrays to achieve what you want. I have commented the code so that you shall not have a problem understanding it. However if you still do then simply ask :)
Input
Output
Logic
Find last row and last column of input sheet
Store in an array
Get unique names from Column A and Row 1
Define output array
Compare array to store sum
Create new sheet and output to that sheet
Code
Option Explicit
Sub Sample()
Dim ws As Worksheet, wsNew As Worksheet
Dim tempArray As Variant, OutputAr() As Variant
Dim officeCol As New Collection
Dim productCol As New Collection
Dim itm As Variant
Dim lrow As Long, lcol As Long, totalsum As Long
Dim i As Long, j As Long, k As Long
'~~> Input sheet
Set ws = Sheet1
With ws
'~~> Get Last Row and last column
lrow = .Range("A" & .Rows.Count).End(xlUp).Row
lcol = .Cells(1, Columns.Count).End(xlToLeft).Column
'~~> Store it in a temp array
tempArray = .Range(.Cells(2, 1), .Cells(lrow, lcol)).Value
'~~> Create a unique collection using On error resume next
On Error Resume Next
For i = LBound(tempArray) To UBound(tempArray)
officeCol.Add tempArray(i, 1), CStr(tempArray(i, 1))
productCol.Add tempArray(i, 2), CStr(tempArray(i, 2))
Next i
On Error GoTo 0
End With
'~~> Define you new array which will hold the desired output
ReDim OutputAr(1 To officeCol.Count + 1, 1 To productCol.Count + 1)
'~~> Store the rows and columns in the array
i = 2
For Each itm In officeCol
OutputAr(i, 1) = itm
i = i + 1
Next itm
i = 2
For Each itm In productCol
OutputAr(1, i) = itm
i = i + 1
Next itm
'~~> Calculate sum by comparing the arrays
For i = 2 To officeCol.Count + 1
For j = 2 To productCol.Count + 1
totalsum = 0
For k = LBound(tempArray) To UBound(tempArray)
If OutputAr(i, 1) = tempArray(k, 1) And _
OutputAr(1, j) = tempArray(k, 2) Then
totalsum = totalsum + tempArray(k, 3)
End If
Next k
OutputAr(i, j) = totalsum
Next j
Next i
'~~> Create a new sheet
Set wsNew = ThisWorkbook.Sheets.Add
'~~> Outout the array
wsNew.Range("A1").Resize(officeCol.Count + 1, productCol.Count + 1).Value = OutputAr
End Sub