给的区间条件，计数，且求和之难题

wowo000

各位老师：晚上好！敬请帮俺解决这个烧脑难题（详见附件），谢谢！

wowo000

抱歉，补充一点：附件里Sheet2里的模拟效果（是当消费金额满足给定的区域条件，对其求和，同时对其所对应的数量求和，并且对相应区域的计数），附件已经更新。特此更正，恳请哪位老师帮忙，谢谢！

lihaosh

过程中调用自定义函数解决吧，这个工作量不少哈

chxw68

1. Sub test2()
   
2.     Dim r%, i%
   
3.     Dim arr, brr(1 To 5, 1 To 5)
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     With Worksheets("sheet1")
   
7.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.         arr = .Range("a2:c" & r)
   
9.     End With
   
10.     For i = 1 To UBound(brr) - 1
    
11.         Set d(i) = CreateObject("scripting.dictionary")
    
12.     Next
    
13.     For i = 1 To UBound(arr)
    
14.         Select Case arr(i, 2)
    
15.             Case Is <= 10
    
16.                 m = 1
    
17.             Case Is <= 50
    
18.                 m = 2
    
19.             Case Is <= 100
    
20.                 m = 3
    
21.             Case Else
    
22.                 m = 4
    
23.         End Select
    
24.         If Not d(m).exists(arr(i, 1)) Then
    
25.             ReDim crr(1 To 2)
    
26.             crr(1) = arr(i, 2)
    
27.             crr(2) = arr(i, 3)
    
28.         Else
    
29.             crr = d(m)(arr(i, 1))
    
30.             crr(1) = crr(1) & "+" & arr(i, 2)
    
31.             crr(2) = crr(2) & "+" & arr(i, 3)
    
32.         End If
    
33.         d(m)(arr(i, 1)) = crr
    
34.         brr(m, 2) = brr(m, 2) + arr(i, 2)
    
35.         brr(m, 3) = brr(m, 3) + arr(i, 3)
    
36.     Next
    
37.     For i = 1 To UBound(brr) - 1
    
38.         For Each bb In d(i).keys
    
39.             crr = d(i)(bb)
    
40.             brr(i, 4) = brr(i, 4) & vbLf & bb & "," & crr(1)
    
41.             brr(i, 5) = brr(i, 5) & vbLf & bb & "," & crr(2)
    
42.         Next
    
43.         brr(i, 1) = d(i).Count
    
44.     Next
    
45.     For i = 1 To UBound(brr)
    
46.         For j = 4 To 5
    
47.             If Len(brr(i, j)) <> 0 Then
    
48.                 brr(i, j) = Mid(brr(i, j), 2)
    
49.             End If
    
50.         Next
    
51.     Next
    
52.     For j = 1 To 3
    
53.         For i = 1 To UBound(brr) - 1
    
54.             brr(UBound(brr), j) = brr(UBound(brr), j) + brr(i, j)
    
55.         Next
    
56.     Next
    
57.     With Worksheets("sheet3")
    
58.         .Range("b2").Resize(UBound(brr), UBound(brr, 2)) = brr
    
59.     End With
    
60. End Sub
    

复制代码

chxw68

详见附件。

zjzyj

附件供参考      

wowo000

chxw68 发表于 2023-4-12 21:28
详见附件。

谢谢您！尊敬的chxw68老师。衷心感谢您再次的帮助！！！