[已解决]VBA的求和结果为什么不对？谢谢老师们！

ligh1298

1. 
   
2. Sub 按人汇总()
   
3. Dim i%, k%, j%, d As Object, arr()
   
4. ReDim Preserve arr(1 To 42, 1 To 2)
   
5. For i = 1 To 3
   
6. a = Cells(65536, 2 * i - 1).End(3).Row
   
7. For Each Rng In Range(Cells(2, 2 * i - 1), Cells(a, 2 * i - 1))
   
8. If Rng <> "" Then
   
9. k = k + 1
   
10. arr(k, 1) = Cells(Rng.Row, 2 * i - 1)
    
11. arr(k, 2) = Cells(Rng.Row, 2 * i)
    
12. End If
    
13. Next
    
14. Next
    
15. Set d = CreateObject("scripting.dictionary")
    
16. For j = 1 To UBound(arr)
    
17. If Not d.exists(arr(j, 1)) Then
    
18. d.Add (arr(j, 1)), arr(j, 2)
    
19. d(arr(j, 1)) = d(arr(j, 1)) + arr(j, 2)
    
20. End If
    
21. Next
    
22. Cells(2, "h").Resize(d.Count, 1) = Application.Transpose(d.keys)
    
23. Cells(2, "i").Resize(d.Count, 1) = Application.Transpose(d.items)
    
24. End Sub
    

复制代码

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-6-1 18:44

1.     For j = 1 To UBound(arr)
   
2.         If Not d.exists(arr(j, 1)) Then
   
3.             d.Add (arr(j, 1)), arr(j, 2)
   
4.         Else
   
5.             d(arr(j, 1)) = d(arr(j, 1)) + arr(j, 2)
   
6.         End If
   
7.     Next

复制代码

跳转到最佳答案楼层

hwc2ycy

1.     For j = 1 To UBound(arr)
   
2.         If Not d.exists(arr(j, 1)) Then
   
3.             d.Add (arr(j, 1)), arr(j, 2)
   
4.         Else
   
5.             d(arr(j, 1)) = d(arr(j, 1)) + arr(j, 2)
   
6.         End If
   
7.     Next

复制代码

hwc2ycy

对于存在的你没有进行累加了。

hwc2ycy

1. Sub 按人汇总2()
   
2.     Dim arr
   
3.     Dim arrResult()
   
4.     Dim i As Long, j As Long, lRecord&, k&
   
5. 
   
6.    
   
7.     arr = Range("a1").CurrentRegion
   
8.     k = k + 1
   
9.    
   
10.     Dim objDic As Object
    
11.     Set objDic = CreateObject("scripting.dictionary")
    
12. 
    
13.     ReDim arrResult(1 To UBound(arr) * UBound(arr, 2) / 2 + 1, 1 To 2)
    
14.     arrResult(1, 1) = "姓名"
    
15.     arrResult(1, 2) = "成绩"
    
16.    
    
17.     For j = LBound(arr) + 1 To UBound(arr)
    
18.         For i = LBound(arr, 2) To UBound(arr, 2) Step 2
    
19.             If Len(arr(j, i)) > 0 Then
    
20.                 If Not objDic.exists(arr(j, i)) Then
    
21.                     k = k + 1
    
22.                     objDic(arr(j, i)) = k
    
23.                     lRecord = k
    
24.                     arrResult(lRecord, 1) = arr(j, i)
    
25.                 Else
    
26.                     lRecord = objDic(arr(j, i))
    
27.                 End If
    
28.                 arrResult(lRecord, 2) = arrResult(lRecord, 2) + arr(j, i + 1)
    
29. 
    
30.             End If
    
31.         Next
    
32.     Next
    
33.     Range("n1").Resize(k, 2).Value = arrResult
    
34.     Set objDic = Nothing
    
35. End Sub
    

复制代码

ligh1298

刚仔细看代码，找到原因了。感谢班亲的提醒，俺上附件，与大家分享。
Sub 按人汇总()
Dim i%, k%, j%, a%, b%, d As Object, arr() '申明变量类型
a = Application.CountIf(Range("a2:f" & Sheet1.UsedRange.Rows.Count), "<>") / 2 '区域内3列姓名中，不为空的个数
ReDim Preserve arr(1 To a, 1 To 2) '重新申明变量
For i = 1 To 3 '循环三次：姓名有三列。
b = Cells(65536, 2 * i - 1).End(3).Row '每列姓名有数据的最大行号。
For Each Rng In Range(Cells(2, 2 * i - 1), Cells(b, 2 * i - 1)) '遍历有姓名的列，第1列；第2列；第3列。
If Rng <> "" Then '如果姓名列不等于空
k = k + 1 '计数、累加
arr(k, 1) = Cells(Rng.Row, 2 * i - 1) '将姓名赋值给数组?1维
arr(k, 2) = Cells(Rng.Row, 2 * i) '将相对应姓名的成绩赋值给数组
End If
Next
Next
Set d = CreateObject("scripting.dictionary") '调用字典
For j = 1 To UBound(arr) '按字典的一维数，从1到数组的上限循环
d(arr(j, 1)) = d(arr(j, 1)) + arr(j, 2) '根据字典关键字（不重复姓名），对成绩进行累加。
Next
Range("h2:i" & [h65536].End(3).Row + 1).ClearContents '清空要写入数据区域
[h2].Resize(d.Count) = Application.Transpose(d.keys) '将字典的关键字（即不重复姓名）写入到H列。
[i2].Resize(d.Count) = Application.Transpose(d.items) '按字典里关键字对相应成绩求和写入到I列。
End Sub

无聊的疯子

ligh1298 发表于 2013-6-1 19:51
刚仔细看代码，找到原因了。感谢班亲的提醒，俺上附件，与大家分享。
Sub 按人汇总()
Dim i%, k%, j%, d  ...

其实这样的数据源可以不用字典的{:101:}{:101:}


感谢你的分享，这样可以帮助好多人了！！

ligh1298

无聊的疯子 发表于 2013-6-1 19:56
其实这样的数据源可以不用字典的

近期在学习VBA的数组、字典。为了巩固，才自己整个题目，练练手。非常感谢老师您的关注！