从数据表/字典到工作表的字典

Question

早安，

我有一个表格，其中包含以下格式的每个部门每周的销售额：

       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
 ...

我需要做的是创建一个较小的报告来汇总每个部门的销售额。按照以下模板：

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

每个部门的行数各不相同。然后这个报告应该打印在电子表格上。

据我了解，这可以使用字典或集合来完成。到目前为止，我已经设法计算出每周的总和，但是，我不明白如何将这些结果转移到工作表中。我尝试将总和转移到数组中，但没有成功。

这是我到目前为止的代码。它正确计算每周的总和，然后清空集合并再次计算下一周的总和。所以，我遇到的主要问题是如何将这些结果写入工作表。

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

感谢任何帮助。谢谢。

Answer 1

您可能有一个有效的代码，但我想向您展示一种不同的方法来实现您的目标。

这种方法包括三件事。

1-将字典中的唯一键（部门名称）控制为键。

2-您的每周总和存储在一个数组中，作为您的值 字典。

在一行中使用Application.SumIf 将您的唯一部门名称相加。

您的字典的最终结果将如下所示（我使用您的模板进行演示和简单比较）：

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

例如：

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

如您所见，值是数组，其中包含部门名称的每周总和。

但是，这些数组不是为每个部门名称声明的。它们实际上是另一个数组中的数组，就像这样：

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

例如：

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

现在，如果你想得到 dept3 每周的总数，基本上是

arr1(2) 即 (50,40,60)

如果你想得到 dept3 第二周的总数，那就是

arr1(2)(1) 即 40

我希望你能明白。在我们开始之前还有一件事，你在你的代码中评论了：

'即出现部门名称的栏目

'第 5 列是每周数据的开始位置

'前1个包含标题

所以我也这样做了，代码如下：

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

您的代码实际上几乎是完整的并且运行良好，尽管我想评论一些习惯可以在尝试调试它时为您节省很多痛苦。

首先，建立一组引用您的Workbook 和Worksheets 的变量。这样做将非常清楚哪些单元格和哪些工作表被引用，并将保持一切正常。此外，请始终使用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")

接下来，请不要使用与变量类型相同的名称 (collection As collection) 来命名您的变量。这不仅令人困惑，而且类型名称在任何编译器中都是保留字。使用更能说明您声明和使用它们的原因的变量名称。

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

您将在我的示例代码中看到，我将变量声明为尽可能接近它们首次使用的位置。这是为了加强每个变量的Type，并确保将其初始化为可接受的值。以下是包含这些概念的循环：

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

最后，要将您的汇总结果放回 (a) 工作表，只需要在主循环中再进行一个循环来捕获每一列：

'--- 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

所以，你现在的日常是：

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