统计同时计数和求和

huangxuejin

我小白一个，在本论坛下载一个VBA代码试图使用，但运行没反应，请各位老师伸出援助之手...

wang-way

鲜花店练手

1. '' 过程开始 X改为你想要的名字
   
2. Public Sub X()
   
3.     '' 代码从这里开始写
   
4.     '' 声明名为dic的变量
   
5.     Dim dic As Object
   
6.     '' 创建一个字典dic
   
7.     Set dic = CreateObject("Scripting.Dictionary")
   
8.     '' 声明工作簿变量wb和工作表变量sht
   
9.     Dim wb As Workbook, sht As Worksheet
   
10.     '' 设置wb为当前工作簿
    
11.     Set wb = Application.ThisWorkbook
    
12.     '' 设置sht为指定名称的工作表，引号内填写工作表名称
    
13.     Set sht = wb.Worksheets(1)
    
14.     '' 使用With语句，方便对工作表Sht进行多次操作
    
15.     With sht
    
16.         '.Usedrange.Offset(1).clear
    
17.         '' 获取列A中最大数据行的行号
    
18.         eRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    
19.         '' 设置范围从A2开始到Z列的eRow行结束
    
20.         Set Rng = .Range("A3:Z" & eRow)
    
21.         '' 将范围Rng的值赋给数组Arr
    
22.         arr = Rng.Value
    
23.         '' 变量 i 从数组Arr最小索引开始，遍历至其最大索引
    
24.         For i = LBound(arr) To UBound(arr)
    
25.             Key = CStr(arr(i, 4))
    
26.             '' 若字典dic中不存在键key 则执行
    
27.             If Not dic.Exists(Key) Then
    
28.                 '' 创建一个数组Ar，只有一个元素1
    
29.                 '' 若字典dic中不存在键key 则执行
    
30.                 Ar = Array(Key, 1, arr(i, 7))
    
31.                 '' 把键值对 key-Ar 存入数组，key与Ar是一 一对应关系
    
32.                 dic(Key) = Ar
    
33.             Else
    
34.                 '' 若字典dic中存在键key 则执行
    
35.                 '' 取出字典中key对应的数组，赋值给Ar
    
36.                 Ar = dic(Key)
    
37.                 '' 对取出的数组Ar执行一些操作
    
38.                 Ar(1) = Ar(1) + 1
    
39.                 Ar(2) = Ar(2) + arr(i, 7)
    
40.                 '' 再次把键值对 key-Ar 存入数组，key与Ar是一 一对应关系
    
41.                 dic(Key) = Ar
    
42.             End If
    
43.         Next i
    
44.         ' 设置范围为A2单元格
    
45.         Set Rng = .Range("j3")
    
46.         ' 调整范围Rng的大小，行数为字典键值对数量dic.Count，列数为2
    
47.         Set Rng = Rng.Resize(dic.Count, 3)
    
48.         ' 调整范围Rng的大小，行数为字典键值对数量dic.Count，列数为值数组的元素数量
    
49.         Rng.Value = Application.Rept(dic.items, 1)
    
50.     End With
    
51. End Sub
    
52. '' 过程结束
    

复制代码

liulang0808

huangxuejin

liulang0808 发表于 2024-6-14 07:59

感谢版主，在百忙之中用最宝贵时间为我解忧，谢谢、谢谢

ynzsvt

1. Sub Dicttl1()
   
2. 
   
3. Dim d As Object, Arr, Brr, i&, j&
   
4. 
   
5. Set d = CreateObject("scripting.dictionary")
   
6. 
   
7. '后期字典
   
8. 
   
9. '  d.CompareMode = vbTextCompare
   
10. 
    
11. '不区分字母大小写
    
12. 
    
13. Arr = Range("a1:b" & Cells(Rows.Count, 1).End(xlUp).Row)
    
14. ReDim Brr(1 To UBound(Arr), 1 To 3)
    
15. '数据源装入数组arr
    
16. 
    
17. For i = 2 To UBound(Arr)
    
18. 
    
19.   If Not d.exists(Arr(i, 1)) Then
    
20.    d(Arr(i, 1)) = d.Count + 1
    
21.    Brr(d.Count, 1) = Arr(i, 1)
    
22.   End If
    
23.   j = d(Arr(i, 1))
    
24.   Brr(j, 2) = Brr(j, 2) + 1
    
25.   Brr(j, 3) = Brr(j, 3) + Val(Arr(i, 2))
    
26. Next
    
27. [D2].Resize(d.Count, 3) = Brr
    
28. 
    
29. '查询区域装入数组brr
    
30. 
    
31. With Range("d1:f" & Cells(Rows.Count, 4).End(xlUp).Row)
    
32. 
    
33.   .NumberFormat = "@" '设置文本格式，防止某些文本数值数据变形
    
34. 
    
35.   'brr数组放回单元格区域
    
36. 
    
37. End With
    
38. 
    
39. Set d = Nothing
    
40. 
    
41. '释放字典
    
42. 
    
43. MsgBox "合 计 成 绩 统 计 完 成。"
    
44. 
    
45. End Sub

复制代码

魂断蓝桥

循环一次就可以了

Sub Dicttl1()
    Dim d As Object, arr, brr(1 To 99, 1 To 3), i&, M&
    Set d = CreateObject("scripting.dictionary")
    [D2:F999] = ""
    arr = Range("a1").CurrentRegion
    For i = 2 To UBound(arr)
        If Not d.EXISTS(arr(i, 1)) Then
            M = M + 1
            brr(M, 1) = arr(i, 1)
            brr(M, 2) = 1
            brr(M, 3) = arr(i, 2)
            d(arr(i, 1)) = M
        Else
            brr(d(arr(i, 1)), 2) = brr(d(arr(i, 1)), 2) + 1
            brr(d(arr(i, 1)), 3) = brr(d(arr(i, 1)), 3) + arr(i, 2)
        End If
    Next
    [d2].Resize(M, 3) = brr
    Set d = Nothing
    MsgBox "合 计 成 绩 统 计 完 成。"
End Sub

huangxuejin

ynzsvt 发表于 2024-6-14 08:15

感谢老师的出手援助，谢谢、

ykcbf1100

还是新写一个吧，字典经典用法。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.6.14  排重统计,字典经典用法
   
2.     Dim arr, brr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     r = Cells(Rows.Count, 1).End(3).Row
   
6.     arr = [a1].Resize(r, 2)
   
7.     ReDim brr(1 To UBound(arr), 1 To 3)
   
8.     For i = 2 To UBound(arr)
   
9.         s = arr(i, 1)
   
10.         If Not d.Exists(s) Then
    
11.             m = m + 1
    
12.             d(s) = m
    
13.             brr(m, 1) = arr(i, 1)
    
14.             brr(m, 2) = 1
    
15.             brr(m, 3) = arr(i, 2)
    
16.         Else
    
17.             r = d(s)
    
18.             brr(r, 2) = brr(r, 2) + 1
    
19.             brr(r, 3) = brr(r, 3) + arr(i, 2)
    
20.         End If
    
21.     Next
    
22.     [d2:f10000] = ""
    
23.     [d2].Resize(m, 3) = brr
    
24.     Set d = Nothing
    
25.     Application.ScreenUpdating = True
    
26.     MsgBox "OK！"
    
27. End Sub
    

复制代码

sdytsxd991122

wps

huangxuejin

魂断蓝桥 发表于 2024-6-14 08:24
循环一次就可以了

Sub Dicttl1()

感谢老师们的相助，谢谢、谢谢