如何对班级成绩统计代码优化

lhlprc

各位大师：我是初学者，学艺不精，我自己写了一个代码用于求班级成绩统计。
我是将每一个科目的成绩都建了一个字典，用于按班级和组别统计人数，按班级和组别统计分数。我还将每个分数段也建立了
一个字典，用于统计在分数段的人数。
我觉得我写的代码太长了，而且很多是重复代码，不容易阅读。我想能不能对代码进行优化一下，使得代码更加简练，效率更高，运行更快。
谢谢！

grf1973

1. Sub 班级平均分统计New()
   
2.     arr = Sheet1.[a1].CurrentRegion
   
3.     Set d = CreateObject("scripting.dictionary")         '各组的班级情况
   
4.     Set d1 = CreateObject("scripting.dictionary")         '各班的人数
   
5.     Set d2 = CreateObject("scripting.dictionary")         '各班+学科的总分
   
6.     For i = 3 To UBound(arr)
   
7.         zb = arr(i, 3)      '组别
   
8.         bj = arr(i, 4)     '班级
   
9.         If Not d.exists(zb) Then        '字典d：各组的班级情况
   
10.             d(zb) = "," & bj & ","
    
11.         Else
    
12.             If InStr(d(zb), "," & bj & ",") = 0 Then d(zb) = d(zb) & bj & ","
    
13.         End If
    
14.         If arr(i, 13) > 0 Then
    
15.             d1(bj) = d1(bj) + 1 '总分不为0，班级人数+1
    
16.             For j = 5 To 12
    
17.                 xk = arr(2, j)    '学科
    
18.                 d2(bj & xk) = d2(bj & xk) + arr(i, j)
    
19.             Next
    
20.         End If
    
21.     Next
    
22.    
    
23.     For Each zb In d.keys
    
24.         Worksheets.Add after:=Sheets(Sheets.Count)
    
25.         With ActiveSheet
    
26.             .Name = zb             '& "班级平均分统计"
    
27.             Sheet2.[a14:l16].Copy .Cells(1, 1)
    
28.             x = Mid(d(zb), 2, Len(d(zb)) - 2) '去掉字符串首尾的逗号
    
29.             xrr = Split(x, ",")
    
30.             .[a4].Resize(UBound(xrr) + 1) = Application.Transpose(xrr)      '把该组的班级填到表中
    
31.             arr = .[a1].CurrentRegion
    
32.             For i = 4 To UBound(arr)
    
33.                 bj = arr(i, 1)
    
34.                 For j = 2 To 9
    
35.                     xk = Replace(arr(3, j), " ", "") '学科（去掉表头中可能有的空格）
    
36.                     arr(i, j) = Format(d2(bj & xk) / d1(bj), "0.00")  '均分=班级+学科的总分/班级人数
    
37.                     s = s + Val(arr(i, j))          '总分
    
38.                 Next
    
39.                 arr(i, j) = s: s = 0
    
40.             Next
    
41.             .[a1].CurrentRegion = arr
    
42.         End With
    
43.     Next
    
44.    
    
45. End Sub

复制代码

grf1973

三个字典足矣！一个存入组班情况，用于生成新表，并在新表中A列填入各班；一个记录各班有效人数；一个记录各班各科的总分。
附件只做到求出各科均分和总均分。最后两列完全可以通过表格操作实现，未写代码。下面的分数段有现成的子程序也未写代码。

lhlprc

grf1973 发表于 2015-7-8 10:37
三个字典足矣！一个存入组班情况，用于生成新表，并在新表中A列填入各班；一个记录各班有效人数；一个记录各 ...

谢谢老师指导，我下去研究，并修改代码完善这个表