美好的一天，
我有一个表格，其中包含每周每个部门的销售额，格式如下：
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
感谢任何帮助。谢谢。
答案 0 :(得分：1)
你的代码实际上已经基本完成并且运行良好，虽然有一些我想评论的习惯会在你试图调试时节省很多痛苦。
首先，建立一组引用您的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
答案 1 :(得分：1)
您可能有一个正常工作的代码，但我想向您展示一种实现目标的不同方法。
这种方法包含3件事。
1 - 将字典中的唯一键（部门名称）控制为键。
2 - 您的每周总和将存储在一个数组中，作为您的值 字典。
3 - 使用
Application.SumIf在一行中汇总您的唯一部门名称。
您词典的最终结果将如下所示（我使用您的模板进行演示和简单比较）：
dict = {key1：value1，key2：value2，key3：value3）
例如：
dict = { “DEPT1” :( 60,60,60）， “DEPT2” :( 40,40,40）， “Dept3” :( 50,40,60）}
正如您所看到的，值是数组，它每周保存一系列dept名称。
但是，没有为每个dept名称声明这些数组。它们实际上是另一个数组中的数组，如下所示：
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列是每周数据开始的地方
'第一个包含标题
所以我做了同样的事情，这是代码：
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