如何用一个字典同时实现多条件求和与计数

china047

无关岁月 发表于 2024-9-5 22:05

多谢老师!

china047

Qs18 发表于 2024-9-5 21:53
试试.........

多谢老师!

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     With Worksheets("sheet1")
   
7.         .AutoFilterMode = False
   
8.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
9.         arr = .Range("a2:d" & r)
   
10.     End With
    
11.     For i = 1 To UBound(arr)
    
12.         xm = arr(i, 1) & "+" & arr(i, 2)
    
13.         If Not d.exists(xm) Then
    
14.             d(xm) = i
    
15.             arr(i, 4) = 1
    
16.         Else
    
17.             m = d(xm)
    
18.             arr(m, 3) = arr(m, 3) + arr(i, 3)
    
19.             arr(m, 4) = arr(m, 4) + 1
    
20.         End If
    
21.     Next
    
22.     ReDim brr(1 To d.Count, 1 To 4)
    
23.     m = 0
    
24.     For Each aa In d.items
    
25.         m = m + 1
    
26.         For j = 1 To UBound(arr, 2)
    
27.             brr(m, j) = arr(aa, j)
    
28.         Next
    
29.     Next
    
30.     With Worksheets("sheet2")
    
31.         .UsedRange.Offset(1, 0).Clear
    
32.         .Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
    
33.     End With
    
34. End Sub
    

复制代码

chxw68

练习。。。。

sdytsxd991122

feilanga

usedrange

1. Sub tt()
   
2.     Dim ar, br, dic, k, i%, t, r%, n
   
3.     Set dic = CreateObject("scripting.dictionary")
   
4.     ar = Sheet1.[a1].CurrentRegion
   
5.     For i = 2 To UBound(ar)
   
6.         dic(0 & "|" & ar(i, 1) & "|" & ar(i, 2)) = dic(0 & "|" & ar(i, 1) & "|" & ar(i, 2)) + ar(i, 3)
   
7.         dic(1 & "|" & ar(i, 1) & "|" & ar(i, 2)) = dic(1 & "|" & ar(i, 1) & "|" & ar(i, 2)) + 1
   
8.     Next i
   
9.     ReDim br(1 To dic.Count / 2, 1 To 4)
   
10.     r = 1
    
11.     For Each k In dic.keys
    
12.         t = Split(k, "|")
    
13.         If t(0) = 0 Then
    
14.             For i = 0 To UBound(t) - 1
    
15.                 br(r, i + 1) = t(i + 1)
    
16.             Next i
    
17.             br(r, 3) = dic(k)
    
18.             n = t(2)
    
19.         End If
    
20.         If t(0) = 1 And t(2) = n Then
    
21.             br(r, 4) = dic(k)
    
22.             r = r + 1
    
23.         End If
    
24.     Next k
    
25.     Sheet2.[a2].Resize(UBound(br), UBound(br, 2)) = br
    
26.     Set dic = Nothing
    
27. End Sub

复制代码

songshihai

这活儿其实还挺简单的,几行就搞定了

sero61

眼高手低的现丑了
Sub dd()
Dim d As New Dictionary, arr
'Set d = CreateObject("scripting.dictionary")
arr = Sheets("sheet1").Range("a1").CurrentRegion

For i = 2 To UBound(arr)
    t = arr(i, 1) & "｜" & arr(i, 2)
    If Not d.Exists(t) Then
        d(t) = Array(arr(i, 1), arr(i, 2), arr(i, 3), 1)
        n = 1
    Else
        n = n + 1
        d(t) = Array(arr(i, 1), arr(i, 2), d(t)(2) + arr(i, 3), n)
    End If
Next i
Sheets("sheet1").Range("e2").Resize(d.Count, 4) = Application.Transpose(Application.Transpose(d.Items))
End Sub

yanglinzi

1. Sub 多条件汇总() '\\2024\9\6
   
2. Dim arr, brr, i, j, sa, r, d
   
3. Set d = CreateObject("scripting.dictionary")
   
4. With Sheet1
   
5.     r = .Cells(Rows.Count, 1).End(xlUp).Row
   
6.     c = .Cells(1, Columns.Count).End(xlToLeft).Column
   
7.     arr = .Range("a1").Resize(r, c)
   
8. End With
   
9. ReDim brr(1 To UBound(arr), 1 To 4)
   
10. For i = 2 To UBound(arr)
    
11.     sa = arr(i, 2)
    
12.     If Not d.exists(sa) Then
    
13.         n = n + 1
    
14.         d(sa) = n
    
15.         brr(n, 1) = arr(i, 1)
    
16.         brr(n, 2) = arr(i, 2)
    
17.         brr(n, 3) = arr(i, 3)
    
18.         brr(n, 4) = 1
    
19.     Else
    
20.         m = d(sa)
    
21.         brr(m, 3) = brr(m, 3) + arr(i, 3)
    
22.         brr(m, 4) = brr(m, 4) + 1
    
23.     End If
    
24. Next
    
25. With Sheet2
    
26.     .Range("g2:j" & r).Clear
    
27.     .[g2].Resize(n, 4) = brr
    
28. End With
    
29. End Sub
    

复制代码