VBA多条件统计计数的问题

gzh491

寻求大神帮助，需要多个条件计数统计，由于数据量较大，用countifs函数运行速度太慢，请大神给帮忙编个VBA程序，在此多多感谢。

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d1 = CreateObject("scripting.dictionary")
   
6.   Set d2 = CreateObject("scripting.dictionary")
   
7.   Set d3 = CreateObject("scripting.dictionary")
   
8.   Set d4 = CreateObject("scripting.dictionary")
   
9.   With Worksheets("问题明细")
   
10.     arr = .Range("h2:h4")
    
11.     For i = 1 To UBound(arr)
    
12.       If Len(arr(i, 1)) <> 0 Then
    
13.         d1(arr(i, 1)) = ""
    
14.       End If
    
15.     Next
    
16.     .Range("i10:bp41").ClearContents
    
17.     brr = .Range("h8:bp41")
    
18.     For i = 3 To UBound(brr) - 2
    
19.       d2(brr(i, 1)) = i
    
20.     Next
    
21.     For j = 2 To UBound(brr, 2)
    
22.       xm = brr(1, j) & "+" & brr(2, j)
    
23.       d3(xm) = j
    
24.     Next
    
25.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
26.     arr = .Range("a2:d" & r)
    
27.     For i = 1 To UBound(arr)
    
28.       If d1.exists(arr(i, 4)) Then
    
29.         If d2.exists(arr(i, 1)) Then
    
30.           m = d2(arr(i, 1))
    
31.         Else
    
32.           m = d2("其他")
    
33.         End If
    
34.         xm = arr(i, 2) & "+" & arr(i, 3)
    
35.         If d3.exists(xm) Then
    
36.           n = d3(xm)
    
37.           brr(m, n) = brr(m, n) + 1
    
38.         End If
    
39.       End If
    
40.     Next
    
41.   End With
    
42.   With Worksheets("生产数量")
    
43.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
44.     arr = .Range("a2:c" & r)
    
45.     For i = 1 To UBound(arr)
    
46.       If d1.exists(arr(i, 3)) Then
    
47.         xm = Replace(arr(i, 1), ".", "+")
    
48.         d4(xm) = d4(xm) + arr(i, 2)
    
49.       End If
    
50.     Next
    
51.   End With
    
52.   For j = 2 To UBound(brr, 2)
    
53.     For i = 3 To 32
    
54.       brr(33, j) = brr(33, j) + brr(i, j)
    
55.     Next
    
56.     xm = brr(1, j) & "+" & brr(2, j)
    
57.     If d4.exists(xm) Then
    
58.       brr(34, j) = d4(xm) - brr(33, j)
    
59.     End If
    
60.   Next
    
61.   With Worksheets("问题明细")
    
62.     .Range("h8:bp41") = brr
    
63.   End With
    
64. End Sub
    
65. 
    

复制代码

chxw68

详见附件。

xiangbaoan

……已做出来了，仅供测试……

经楼主反馈，9月17日补充：
把附件中
y = IIf(d.exists(br(r, 1)), d(br(r, 1)), d("其他"))
改成
y = IIf(Len(d(br(r, 1))), d(br(r, 1)), d("其他"))

xiangbaoan

楼主，你要反馈！

gzh491

xiangbaoan 发表于 2018-9-16 18:41
楼主：
注册时间2009-1-5
最后登录2018-9-15

多谢大神，主要是周六、周天休息，数据在公司电脑上，所以没测试
您编写的程序很好，还有一个问题，就是数据量很多，出现下标越界的问题


我现在数据超过了7万多行，显示下标越界

gzh491

chxw68 发表于 2018-9-14 15:13
详见附件。

谢谢老师，不过没有达到想要的效果，下面一位老师给出了想要的效果，在此也非常感谢您的回复。

gzh491

xiangbaoan 发表于 2018-9-16 18:41
楼主：
注册时间2009-1-5
最后登录2018-9-15

由于数据量大，超过上传的限制，所以附件无法上传，请大神帮忙修改一下，谢谢

小风风风

给顶一下,自己等级积分都不够...赚点分

xiangbaoan

gzh491 发表于 2018-9-17 09:12
由于数据量大，超过上传的限制，所以附件无法上传，请大神帮忙修改一下，谢谢

若行，可将附件发送到，我的用户名 艾特  qq  点  com，有空时义务帮忙再搞一下。