Dictionary from table of data / dictionary to worksheet

Question

Good day,

I have a table with data that contains sales per department per each week in the following format:

       Week1 Week2 Week3 ...
Dept1   10    20    10
Dept1   20    10    30
Dept1   30    30    20
Dept2   20    20    30
Dept2   20    20    10
Dept3   50    40    60
 ...

What I need to do is to create a smaller report that will sum up the sales per department. As per following template:

       Week1 Week2 Week3
Dept1   60    60    60
Dept2   40    40    40
Dept3   50    40    60
Total   150   140   160

The number of rows per department varies. Then this report should be printed on the spreadsheet.

From what I understand, this is possible to be done using dictionaries or collections. So far I have managed to calculate the sums per each week, however, I don't understand how to transfer these results to the worksheet. I have tried transferring the sums to the array but it didn't work.

This is the code I have so far. It correctly calculates the sums per week, then empties the collection and calculates it again for the following week. So, the main problem I have is how to write these results to the worksheet.

Dim collection As collection
Dim dataitems As Itemlist 'defined in classmodule
Dim key As String
Dim item As Double
Dim row As Long, column As Long
Dim lstrow As Long, lstcolumn As Long

Set collection = New collection
columnindex = 3 'that is the column where name of departments appear
lstrow = Sheet1.Cells(Sheet1.Rows.Count, column).End(xlUp).row
lstcolumn = Sheet1.Cells(1, Sheet1.Columns.Count).End(xlToLeft).column

For column = 5 To lstcolumn 'column 5 is where the weekly data start
    For row = 2 To lstrow 'first 1 contains titles
        key = CStr(Sheet1.Cells(row, "C").Value2)
        item = CDbl(Sheet1.Cells(row, column).Value2)

        Set dataitems = Nothing: On Error Resume Next
        Set dataitems = collection(key): On Error GoTo 0

        If dataitems Is Nothing Then
            Set dataitems = New Itemlist
            dataitems.key = key
            collection.Add dataitems, key
        End If

        With dataitems
            .Sum = .Sum + item
            .Itemlist.Add item
        End With
    Next

Set collection = New collection

Next

Any help is appreciated. Thank you.

Answer 1

You might have a working code, but I want to show you a different approach to achieve your goal.

This approach consists of 3 things.

1-Control your unique keys(dept names) in a dictionary as keys.

2-Your weekly sums to be stored in an array, as values of your dictionary.

3-Sum your unique dept names using Application.SumIf in a single line.

The final result of your dictionary will look like this (I used your template for demonstration and easy comparison):

dict = {key1:value1,key2:value2,key3:value3)

For example:

dict = {"Dept1":(60,60,60),"Dept2":(40,40,40),"Dept3":(50,40,60)}

As you can see values are arrays, which hold weekly sums of dept names.

However, these arrays are not declared for each dept name. They are actually arrays inside of another array just like this:

arr1 = (arr1_1(),arr1_2(),arr1_3())

For example:

arr1 = ((60,60,60),(40,40,40),(50,40,60))

Now, if you want to get dept3 weekly totals, basically it is

arr1(2) which is (50,40,60)

If you want to get dept3 second week totals, it is

arr1(2)(1) which is 40

I hope you get the idea.One more thing before we start, you commented in your code:

'that is the column where name of departments appear

'column 5 is where the weekly data start

'first 1 contains titles

So I did the same, here is the code:

Sub ArrayMyDictionary()
Dim dict As Object, lastrow As Long, lastcol As Long, i As Long, j As Long, c As Long
Dim arr1() As Variant, arr2() As Variant
Set dict = CreateObject("Scripting.Dictionary")

With Worksheets("Sheet1")
    lastrow = .Cells(.Rows.Count, 3).End(xlUp).Row
    lastcol = .Cells(1, .Columns.Count).End(xlToLeft).Column

    ReDim arr1(c) 'array1 initial size 0, later on size is number dept
    ReDim arr2(lastcol - 5) 'array2 size is number of weeks

    For i = 2 To lastrow
        If Not dict.Exists(.Cells(i, 3).Value) Then 'check if Dept not exists in dict
            ReDim Preserve arr1(c)
            arr1(c) = arr2() ' create empty array2 (size is number of weeks) as an element of current array1
            For j = 5 To lastcol
                arr1(c)(j - 5) = Application.SumIf(.Range(.Cells(2, 3), .Cells(lastrow, 3)), .Cells(i, 3).Value, .Range(.Cells(2, j), .Cells(lastrow, j)))
            Next
            dict(.Cells(i, 3).Value) = arr1(c) ' create key (Dept name) and value (an array that holds relevant weekly sums)
            c = c + 1
        End If
    Next
End With

'this part will print out your results to Sheet2
With Worksheets("Sheet2")
    Dim key As Variant
    For Each key In dict.Keys
        .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0) = key 'last empty row - print key
        For j = 0 To lastcol - 5
            .Cells(.Rows.Count, 1).End(xlUp).Offset(0, j + 1) = dict(key)(j) 'same row proceed to cell on right - print each element in array inside value
        Next j
    Next key
    .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0) = "Total" 'last row - calculate totals
    For j = 0 To lastcol - 5
        .Cells(.Rows.Count, 1).End(xlUp).Offset(0, j + 1) = Application.WorksheetFunction.Sum(.Columns(j + 2)) 'same row proceed to cell on right - sum of columns
    Next j
End With
End Sub

Answer 2

Your code is really almost complete and works well enough, though there are some habits I'd like to comment on that will save you lots of anguish when trying to debug it.

First of all, establish a set of variables that refers to your Workbook and Worksheets. Doing this will make it very clear which cells and which sheets are being referenced and will keep it all straight. Additionally, ALWAYS use Option Explicit.

Dim thisWB As Workbook
Dim thisWS As Worksheet
Dim destWS As Worksheet
Set thisWB = ThisWorkbook
Set thisWS = thisWB.Sheets("Sheet1")
Set destWS = thisWB.Sheets("Sheet2")

Next, please don't name your variable using the same name as the variable type (collection As collection). Not only is this confusing, but the type names are reserved words in any compiler. Use variables names that are more descriptive of why you're declaring and using them.

Dim deptTotal As Itemlist
Dim deptWeeklyTotals As collection
Set deptWeeklyTotals = New collection

Because you've decided to hard-code some of the columns and rows (which is fine), you should use define these values as constants. Later, if those values change you only have to change them in one place.

Const DEPT_NAME_COL As Long = 3
Dim lastRow As Long
Dim lastCol As Long
lastRow = thisWS.Cells(thisWS.Rows.Count, DEPT_NAME_COL).End(xlUp).row
lastCol = thisWS.Cells(1, thisWS.Columns.Count).End(xlToLeft).column

Const WEEK1_COL As Long = 5
Const FIRST_DATA_ROW As Long = 2

You'll see in my example code that I'm declaring my variables as close as possible to the location they are used for the first time. This is to reinforce the Type of each variable and make sure it's initialized to an acceptable value. Here's your loop with these concepts in place:

Dim i As Long
Dim j As Long
Dim needsDeptLabels As Boolean
needsDeptLabels = True
For i = WEEK1_COL To lastCol
    For j = FIRST_DATA_ROW To lastRow
        Dim deptName As String
        Dim weekTotal As Double
        deptName = CStr(thisWS.Cells(j, DEPT_NAME_COL).Value2)
        weekTotal = CDbl(thisWS.Cells(j, i).Value2)

        Set deptTotal = Nothing
        On Error Resume Next
        Set deptTotal = deptWeeklyTotals(deptName)
        On Error GoTo 0

        If deptTotal Is Nothing Then
            Set deptTotal = New Itemlist
            deptTotal.key = deptName
            deptWeeklyTotals.Add deptTotal, deptName
        End If

        With deptTotal
            .sum = .sum + weekTotal
            .Itemlist.Add weekTotal
        End With
    Next j

    '--- set up for the next week
    Set deptWeeklyTotals = New collection
Next i

Lastly, to put your summary results back to (a) worksheet only needs another loop inside the main loop to capture each column:

'--- output the results to the summary table
For j = 1 To deptWeeklyTotals.Count
    If needsDeptLabels Then
        Set deptTotal = deptWeeklyTotals(j)
        destWS.Cells(j, DEPT_NAME_COL).Value = deptTotal.key
    End If
    destWS.Cells(j, i).Value = deptTotal.sum
Next j
needsDeptLabels = False  '- only need to put the labels in once

So all together, your routine is now:

Option Explicit

Sub DeptSummary()
    Dim thisWB As Workbook
    Dim thisWS As Worksheet
    Dim destWS As Worksheet
    Set thisWB = ThisWorkbook
    Set thisWS = thisWB.Sheets("Sheet1")
    Set destWS = thisWB.Sheets("Sheet2")

    Dim deptTotal As Itemlist
    Dim deptWeeklyTotals As collection
    Set deptWeeklyTotals = New collection

    Const DEPT_NAME_COL As Long = 3
    Dim lastRow As Long
    Dim lastCol As Long
    lastRow = thisWS.Cells(thisWS.Rows.Count, DEPT_NAME_COL).End(xlUp).row
    lastCol = thisWS.Cells(1, thisWS.Columns.Count).End(xlToLeft).column

    Const WEEK1_COL As Long = 5
    Const FIRST_DATA_ROW As Long = 2
    Dim i As Long
    Dim j As Long
    Dim needsDeptLabels As Boolean
    needsDeptLabels = True
    For i = WEEK1_COL To lastCol
        For j = FIRST_DATA_ROW To lastRow
            Dim deptName As String
            Dim weekTotal As Double
            deptName = CStr(thisWS.Cells(j, DEPT_NAME_COL).Value2)
            weekTotal = CDbl(thisWS.Cells(j, i).Value2)

            Set deptTotal = Nothing
            On Error Resume Next
            Set deptTotal = deptWeeklyTotals(deptName)
            On Error GoTo 0

            If deptTotal Is Nothing Then
                Set deptTotal = New Itemlist
                deptTotal.key = deptName
                deptWeeklyTotals.Add deptTotal, deptName
            End If

            With deptTotal
                .sum = .sum + weekTotal
                .Itemlist.Add weekTotal
            End With
        Next j

        '--- output the results to the summary table
        For j = 1 To deptWeeklyTotals.Count
            If needsDeptLabels Then
                Set deptTotal = deptWeeklyTotals(j)
                destWS.Cells(j, DEPT_NAME_COL).Value = deptTotal.key
            End If
            destWS.Cells(j, i).Value = deptTotal.sum
        Next j
        needsDeptLabels = False                  '- only need to put the labels in once

        '--- set up for the next week
        Set deptWeeklyTotals = New collection
    Next i

End Sub