Dictionary from data table / dictionary to worksheet

Your code is indeed nearly complete and works well enough, although there are some habits I would like to comment on that will save you a lot of pain when trying to debug it.

First of all, set the set of variables that apply to your Workbook

and Worksheets

. This will make it very clear which cells and which sheets are referenced and will keep everything in order. Also, 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")

      

        
        
        
      

    

Then don't give your variable with the same name as the variable type ( collection As collection

). Not only is this confusing, but type names are reserved words in any compiler. Use variable names that describe in more detail why you are declaring and using them.

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

      

        
        
        
      

    

Since you've decided to hardcode some of the columns and rows (that's okay), you should use these values ​​as constants. Later, if these values ​​change, you only need 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

      

        
        
        
      

    

In my example code, you will see that I am declaring my variables as close as possible to the location they are using the first time. This should reinforce Type

each variable and make sure it is 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

      

        
        
        
      

    

Finally, to return the totals to (a) the worksheet, it only takes one loop inside the main loop for 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 now your routine is:

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