敬请老师指教一下这代码错在哪里，D3合计总无法实现。

wtb8152 · 发表于 2024-9-24 22:18

老师好！
敬请帮我看下这汇总代码错在哪里，或者这样写对不对，B3的合计代码无法运行，一运行就错误。敬请老师指教一下。谢谢！！

leeson7502 · 发表于 2024-9-24 23:13

参与一下：

Sub mySum()
Dim dic As Object, dKey As String
Dim ws As Worksheet, lastRow As Integer, lastCol As Integer
Dim arr(), temp()
Dim total()
'//把数据装入数组
Set dic = CreateObject("Scripting.dictionary")
Set ws = ThisWorkbook.Sheets("明细")
With ws
lastRow = .UsedRange.Rows.Count
lastCol = .UsedRange.Columns.Count
arr = .Range(.Cells(4, 1), .Cells(lastRow, lastCol)).Value
End With
ReDim total(2) '//存合计数
'//把数据以人名为Key，存到数组，Item 为一数组，按key汇总
For i = 1 To UBound(arr)
dKey = arr(i, 3)
If dKey <> "" Then
'//如果字典已存在key，则取值到temp,否则定义一个空数组
If Not dic.exists(dKey) Then
ReDim temp(2)
Else
temp = dic(dKey)
End If
For j = 5 To 6
temp(j - 5) = temp(j - 5) + arr(i, j)
total(j - 5) = total(j - 5) + arr(i, j)
Next
temp(2) = temp(0) - temp(1)
total(2) = total(0) - total(1)
dic(dKey) = temp
End If
Next
'//把人名存入数组，转置，扩展，写入数据
arr = dic.keys
arr = Application.Transpose(arr)
lastRow = UBound(arr)
ReDim Preserve arr(1 To lastRow, 1 To 4)
For i = 1 To lastRow
dKey = arr(i, 1)
temp = dic(dKey)
For j = 0 To 2
arr(i, j + 2) = temp(j)
Next
Next
'//把数据写入工作表
Set ws = ThisWorkbook.Sheets("汇总")
With ws
.Range(.Cells(5, 1), .Cells(.UsedRange.Rows.Count, .UsedRange.Columns.Count)).ClearContents
.Cells(3, 2).Resize(1, 3) = total
.Cells(5, 1).Resize(lastRow, 4) = arr
End With
MsgBox "Done!"
End Sub

复制代码

		自动登录	找回密码
密码			免费注册

[求助] 敬请老师指教一下这代码错在哪里，D3合计总无法实现。