请高手帮忙进行成绩统计

yynrzwh

1. Sub 统计()
   
2. 
   
3. arr = Sheets("成绩表").UsedRange
   
4. Set d = CreateObject("scripting.dictionary")
   
5. 
   
6.     For j = 5 To UBound(arr, 2) - 3
   
7.         For i = 3 To UBound(arr)
   
8.             s = arr(2, j) & "|" & arr(i, 2) '关键字科目+班级
   
9.             If d.exists(s) Then
   
10.                 If arr(i, j) <> "" Then rs = rs + 1 '参考人数
    
11.                 If arr(i, j) >= arr(1, j) * 0.6 Then hg = hg + 1 '合格人数
    
12.                 If arr(i, j) >= arr(1, j) * 0.8 Then yx = yx + 1 '优秀人数
    
13.                 zj = zj + arr(i, j) '班级单科总分
    
14.                 d(s) = Array(zj, rs, hg, yx)
    
15.             Else
    
16.                 rs = 0: hg = 0: yx = 0: zj = 0
    
17.                 If arr(i, j) <> "" Then rs = 1
    
18.                 If arr(i, j) >= arr(1, j) * 0.6 Then hg = 1
    
19.                 If arr(i, j) >= arr(1, j) * 0.8 Then yx = 1
    
20.                 zj = arr(i, j)
    
21.                 d(s) = Array(zj, rs, hg, yx)
    
22.             End If
    
23.         Next i
    
24.     Next j
    
25.    
    
26. ReDim brr(1 To d.Count, 1 To 6)
    
27.     For Each k In d.keys '循环字典，取出数据装入brr
    
28.         n = n + 1
    
29.         sp = Split(k, "|")
    
30.         brr(n, 1) = sp(0): brr(n, 2) = sp(1)
    
31.         brr(n, 3) = d(k)(1): brr(n, 4) = d(k)(0)
    
32.         brr(n, 5) = d(k)(2): brr(n, 6) = d(k)(3)
    
33.     Next k
    
34.    
    
35.     With Sheets("班科统计")
    
36.         .UsedRange.Offset(2).ClearContents '清空
    
37.         .[c3].Resize(n, 6) = brr '写入数据
    
38.     End With
    
39.    
    
40. Set d = Nothing
    
41. End Sub
    

复制代码

liulyc1977

年年用的时候学，过了又忘记了

ykcbf1100

都翻出来了，那就顺便练个手吧。