求助各位老师帮助简化代码，谢谢。

szzhaoguomin

自己用来管理招生信息的表格，在工作表收费汇总中点击数据统计按钮，就会按照分数段和学校统计到数据统计和学校统计两个工作表中，我采用了调用内部函数SUMPRODUCT的方法，导致运算速度缓慢，由于自己vba小白，不会精简代码，请各位老师帮忙优化一下，提高运行速度，谢谢！附件内密码123

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr(1 To 5)
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("学校统计")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     .Range("b3:b" & r).ClearContents
   
9.     crr = .Range("a3:b" & r)
   
10.     For i = 1 To UBound(crr)
    
11.       d(crr(i, 1)) = i
    
12.     Next
    
13.   End With
    
14.   With Worksheets("数据统计")
    
15.     .Range("a4,c4:c9,e4:e9") = ""
    
16.     brr(1) = .Range("a4:e9")
    
17.     .Range("b12:b14") = ""
    
18.     brr(2) = .Range("b12:b14")
    
19.     .Range("b23:d46") = ""
    
20.     brr(4) = .Range("b23:d46")
    
21.     .Range("b50:d72") = ""
    
22.     brr(5) = .Range("b50:d72")
    
23.   End With
    
24.   With Worksheets("收费汇总")
    
25.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
26.     arr = .Range("a2:aa" & r)
    
27.   End With
    
28.   For i = 1 To UBound(arr)
    
29.     If arr(i, 5) = "男" Then
    
30.       m = 1
    
31.     Else
    
32.       m = 3
    
33.     End If
    
34.     If arr(i, 9) = "是" Then
    
35.       n = 1
    
36.     Else
    
37.       n = 2
    
38.     End If
    
39.     If arr(i, 7) = "文" Then
    
40.       l = 1
    
41.     Else
    
42.       l = 2
    
43.     End If
    
44.     brr(1)(1, 1) = brr(1)(1, 1) + 1
    
45.     brr(1)(m, 3) = brr(1)(m, 3) + 1
    
46.     brr(1)(m + n - 1, 5) = brr(1)(m + n - 1, 5) + 1
    
47.     brr(1)(n + 4, 3) = brr(1)(n + 4, 3) + 1
    
48.     brr(2)(l, 1) = brr(2)(l, 1) + 1
    
49.     brr(2)(3, 1) = brr(2)(3, 1) + 1
    
50.     xh = Application.Match(arr(i, 23) + arr(i, 25), Array(0, 400, 410, 420, 430, 440, 450, 460, 470, 480, 490, 500, 510, 520, 530, 540, 550, 560, 570, 580, 590, 600))
    
51.     If Not IsError(xh) Then
    
52.       brr(4)(23 - xh, l + 1) = brr(4)(23 - xh, l + 1) + 1
    
53.       brr(4)(24, l + 1) = brr(4)(24, l + 1) + 1
    
54.       brr(4)(23 - xh, 1) = brr(4)(23 - xh, 1) + 1
    
55.       brr(4)(24, 1) = brr(4)(24, 1) + 1
    
56.     End If
    
57.     xh = Application.Match(arr(i, 25), Array(0, 400, 410, 420, 430, 440, 450, 460, 470, 480, 490, 500, 510, 520, 530, 540, 550, 560, 570, 580, 590, 600))
    
58.     If Not IsError(xh) Then
    
59.       brr(5)(23 - xh, l + 1) = brr(5)(23 - xh, l + 1) + 1
    
60.       brr(5)(23, l + 1) = brr(5)(23, l + 1) + 1
    
61.       brr(5)(23 - xh, 1) = brr(5)(23 - xh, 1) + 1
    
62.       brr(5)(23, 1) = brr(5)(23, 1) + 1
    
63.     End If
    
64.     If d.exists(arr(i, 8)) Then
    
65.       m = d(arr(i, 8))
    
66.       crr(m, 2) = crr(m, 2) + 1
    
67.     End If
    
68.   Next
    
69.   With Worksheets("数据统计")
    
70.     .Range("a4:e9") = brr(1)
    
71.     .Range("b12:b14") = brr(2)
    
72.     .Range("b23:d46") = brr(4)
    
73.     .Range("b50:d72") = brr(5)
    
74.   End With
    
75.   With Worksheets("学校统计")
    
76.     .Range("a3").Resize(UBound(crr), UBound(crr, 2)) = crr
    
77.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
78.     .Cells(r, 2).FormulaR1C1 = "=SUM(R3C:R[-1]C)"
    
79.   End With
    
80. End Sub
    

复制代码

chxw68

详见附件。

不知道为什么

chxw68 发表于 2018-7-12 19:51

chxw68老师，让人敬佩！德才兼备，德艺双馨！👍

szzhaoguomin

非常感谢老师在百忙之中写了这么多代码，运行速度比原来的快太多了，点击一下秒汇总，好好研究一下老师的代码，谢谢~~我运行了一下，发现老师的代码统计出来的数据有几处和我的有出入，我检查一下看看是不是自己统计错了。

chxw68

不知道为什么 发表于 2018-7-12 19:54
chxw68老师，让人敬佩！德才兼备，德艺双馨！👍

谢谢，过奖了！

szzhaoguomin

chxw68 发表于 2018-7-12 20:15
谢谢，过奖了！

刚才我筛选了一下，540-549这个分数段的理科是31个，麻烦老师再看看代码，我应该如何修改，谢谢您。

chxw68

szzhaoguomin 发表于 2018-7-12 20:19
刚才我筛选了一下，540-549这个分数段的理科是31个，麻烦老师再看看代码，我应该如何修改，谢谢您。

把你的数据修改有关信息后发上来。

chxw68

szzhaoguomin 发表于 2018-7-12 20:19
刚才我筛选了一下，540-549这个分数段的理科是31个，麻烦老师再看看代码，我应该如何修改，谢谢您。

问题肯定出在大于549小于550这个区段的小数上。

szzhaoguomin

好的，我把全部数据发上来您再看看，我刚才对标黄色的区域进行了筛选，您的代码统计出来的数据标黄的位置都有差别，我自己统计出来的数据是准确的，烦请老师再看看。