请尝试下一个代码。它假设在 A:A 列中，从第 6 行开始，有（未排序的）任务。如果它们被排序，代码也将毫无问题地运行。它使用数组和字典，主要在内存中工作，对于大范围应该非常快：
Sub SumWeeksMonths()
Dim sh As Worksheet, sh1 As Worksheet, lastR As Long, arrWk, arrMonths, arrTasks
Dim i As Long, k As Long, j As Long, El, arr, arrFin, dict As New Scripting.Dictionary
Set sh = ActiveSheet 'use there the sheet to be processed
Set sh1 = sh.Next 'use here the sheet where the processed result to be returned
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row 'last row (in column A:A)
arrWk = sh.Range(sh.Range("B5"), sh.cells(5, sh.Columns.count).End(xlToLeft)).Value 'place the Week headers in a 2D array
ReDim arrMonths(UBound(arrWk, 2) - 1)'redim the 1D array to keep the unique munths, at a maximum size
For i = 1 To UBound(arrWk, 2) - 1 'create the array of (only) months:
If month(DateValue(arrWk(1, i))) <> month(DateValue(arrWk(1, i + 1))) Then
k = k + 1: arrMonths(k) = Format(DateValue(arrWk(1, i + 1)), "mmm-yyyy")
Else
arrMonths(k) = Format(DateValue(arrWk(1, i)), "mmm-yyyy")
End If
Next i
ReDim Preserve arrMonths(k) 'preserve only the existing Date elements
For Each El In sh.Range("A4:A" & lastR).Value
dict(El) = 1 'extract the unique tasks (only to count them for ReDim the necessary array)
Next El
'place all the range to be processed in an array (for faster iteration):
arr = sh.Range("A5", sh.cells(lastR, sh.cells(5, sh.Columns.count).End(xlToLeft).Column)).Value
ReDim arrFin(1 To UBound(dict.Keys) + 1, 1 To UBound(arrMonths) + 2) 'reDim the final array to keep processed data
ReDim arrTasks(UBound(arrMonths)) 'redim the array to temporarily keep the array of each task summ
dict.RemoveAll: k = 0 'clear the dictionary and reitinialize the K variable
For i = 2 To UBound(arr) 'iterate between the main array elements:
If Not dict.Exists(arr(i, 1)) Then 'if the Task key does not exist:
For Each El In arrMonths 'iterate between each month in arrMonths:
For j = 2 To UBound(arr, 2) 'iterate between all arr columns for the i row:
If month(DateValue(arr(1, j))) = month(El) Then 'if column months is a specific arrMonths column:
arrTasks(k) = arrTasks(k) + arr(i, j) 'sumarize everything in the arrTask each element
End If
Next j
k = k + 1 'increment k, for the next month
Next El
dict.Add arr(i, 1), arrTasks 'create the dictionary key with the tasks array as item
ReDim arrTasks(UBound(arrMonths)): k = 0 'reinitialize arrTasks and k variable
Else 'if dictionary (task) key exists:
For Each El In arrMonths
For j = 2 To UBound(arr, 2)
If month(DateValue(arr(1, j))) = month(El) Then
arrTasks(k) = dict(arr(i, 1))(k) + arr(i, j) 'add the sum to the allready existing elements
End If
Next j
k = k + 1
Next El
dict(arr(i, 1)) = arrTasks 'make the item the updaded array
ReDim arrTasks(UBound(arrMonths)): k = 0 'reinitialize arrTasks and k variable
End If
Next i
'place the processed values in final array (arrFin):
For i = 0 To UBound(arrMonths) 'firstly the headers:
arrFin(1, i + 2) = arrMonths(i)
Next i
'Extract the tasks value for each month and place in the final array appropriate columns:
For i = 0 To dict.count - 1 'iterate between the dictionary elements:
arrFin(i + 2, 1) = dict.Keys(i) 'place the task in the array first column, starting from the second row
For j = 0 To UBound(dict.items(i)) 'iterate between the dictionary item array elements
arrFin(i + 2, j + 2) = dict.items(i)(j) 'place the appropriate array elements in the final array (arrFin)
Next j
Next i
'drop the final array at once and make some formatting:
With sh1.Range("A1").Resize(UBound(arrFin), UBound(arrFin, 2))
.Value = arrFin
With .rows(1)
.Font.Bold = True
.Interior.ColorIndex = 20
.BorderAround 1
End With
.EntireColumn.AutoFit
.BorderAround 1
End With
sh1.Activate 'to see the processing result...
MsgBox "Ready..."
End Sub
请进行测试并发送一些反馈。