用宏统计考试成绩中的各分数段人数

geryjun

在论坛中搜到了这个帖子，基本符合我的要求，但是它只有2个学科，如何增加多个学科。请高手指点，谢谢。

http://club.excelhome.net/forum.php?mod=viewthread&tid=327131&page=7#pid2246560

全部改用数组再加循环，就是再多几个科目也无妨，加快速度
Private Sub CommandButton1_Click()
Dim i, ar
'On Error Resume Next
t = Timer
CommandButton1.Enabled = False
CommandButton2.Enabled = True
i = Sheets("成绩单").[a65536].End(xlUp).Row
ar = Sheets("成绩单").Range("a1:d" & i)
sr = Split("学校,总分,平均分,最高分,最低分,140以上,130~140,120~130,110~120,100~110,90~100,80~90,70~80,60~70,60以下,=0,实考人数", ",")
Set d = CreateObject("scripting.dictionary")
For s = 2 To i
If Not d.exists(ar(s, 1)) Then
d.Add ar(s, 1), ""
End If
Next
With Sheets("分数段")
f16 = 2
For f15 = 4 To (d.Count + 8) * 2 Step d.Count + 8
f16 = f16 + 1
.Range("a" & f15 - 2) = ar(1, f16)
.Range("a" & f15 - 1 & ":q" & f15 - 1) = sr
.Range("a" & f15 + 27) = "总计"
.Range("a" & f15).Resize(d.Count, 1) = WorksheetFunction.Transpose(d.keys)
ar2 = .Range("a" & f15).Resize(d.Count, 17)
For r = 1 To d.Count
f1 = 0: f2 = 0: f3 = 0: f4 = 0: f5 = 0: f6 = 0: f7 = 0: f8 = 0: f9 = 0: f10 = 0: f11 = 0: f17 = 0
f12 = 0: f13 = 0: f14 = 200
For s = 2 To i
If ar(s, 1) = ar2(r, 1) Then
f17 = f17 + 1
'If ar(s, f16) <> "" Then     '如果要考虑缺考者因素启用
Select Case ar(s, f16)
Case 0
f1 = f1 + 1
Case Is < 60
f2 = f2 + 1
Case Is < 70
f3 = f3 + 1
Case Is < 80
f4 = f4 + 1
Case Is < 90
f5 = f5 + 1
Case Is < 100
f6 = f6 + 1
Case Is < 110
f7 = f7 + 1
Case Is < 120
f8 = f8 + 1
Case Is < 130
f9 = f9 + 1
Case Is < 140
f10 = f10 + 1
Case Else
f11 = f11 + 1
End Select

f12 = f12 + Val(ar(s, f16))
If Val(ar(s, f16)) > f13 Then f13 = Val(ar(s, f16))
If ar(s, f16) > 0 And ar(s, f16) < f14 Then f14 = ar(s, f16)
'End If                            '如果要考虑缺考者因素启用
End If
Next
ar2(r, 17) = f17
ar2(r, 16) = f1
ar2(r, 15) = f2
ar2(r, 14) = f3
ar2(r, 13) = f4
ar2(r, 12) = f5
ar2(r, 11) = f6
ar2(r, 10) = f7
ar2(r, 9) = f8
ar2(r, 8) = f9
ar2(r, 7) = f10
ar2(r, 6) = f11
If f12 = 0 Then ar2(r, 5) = 0 Else ar2(r, 5) = f14
ar2(r, 4) = f13
'If ar2(r, 17) - ar2(r, 16) > 0 Then ar2(r, 3) =Round( f12 / (ar2(r, 17) - ar2(r, 16)) ,1)  '如果要考虑缺考者因素启用,下条屏蔽
If f2 + f3 + f4 + f5 + f6 + f7 + f8 + f9 + f10 + f11 > 0 Then ar2(r, 3) = Round(f12 / (f2 + f3 + f4 + f5 + f6 + f7 + f8 + f9 + f10 + f11), 1) Else ar2(r, 3) = 0
ar2(r, 2) = f12
Next
.Range("a" & f15).Resize(d.Count, 17) = ar2
.Range("b" & f15 + 27).FormulaR1C1 = "=SUM(R[-27]C:R[-1]C)":
.Range("c" & f15 + 27) = "=IF(RC[14]-RC[13]>0,RC[-1]/(RC[14]-RC[13]),"""")":
.Range("d" & f15 + 27) = "=max(R[-27]C:R[-1]C)": .Range("e" & f15 + 27) = "=min(R[-27]C:R[-1]C)"
.Range("f" & f15 + 27) = "=sum(R[-27]C:R[-1]C)"
.Range("f" & f15 + 27).AutoFill Destination:=.Range("F" & f15 + 27 & ":Q" & f15 + 27), Type:=xlFillDefault
Next
End With
Set d = Nothing
MsgBox Timer - t
End Sub
Private Sub CommandButton2_Click()
CommandButton2.Enabled = False
CommandButton1.Enabled = True
Cells.ClearContents
End Sub
BNyMgnwn.rar

蓝桥玄霜

1. Public fs, r, Arr1, zgf(), zdf(), rs()
   
2. Sub cjfx()
   
3. Dim d, k, t, d1, k1, t1, bt
   
4. Dim Arr, c, i&, y&, j&, x$
   
5. Set d = CreateObject("Scripting.Dictionary")
   
6. Set d1 = CreateObject("Scripting.Dictionary")
   
7. Application.ScreenUpdating = False
   
8. bt = Split("学校,总分,平均分,最高分,最低分,140以上,130~140,120~130,110~120,100~110,90~100,80~90,70~80,60~70,60以下,=0,实考人数", ",")
   
9. Sheet1.Activate
   
10. Cells.ClearContents
    
11. Cells.Borders.LineStyle = xlNone
    
12. [a4:q30] = ""
    
13. Arr = Sheet2.[a1].CurrentRegion
    
14. For i = 3 To UBound(Arr, 2)
    
15.     d1(Arr(1, i)) = i
    
16. Next
    
17. k1 = d1.keys: t1 = d1.items
    
18. For j = 0 To UBound(k1)
    
19.     ReDim Arr1(1 To 27, 1 To 17)
    
20.     c = t1(j): r = 0
    
21.     For i = 2 To UBound(Arr)
    
22.         If Arr(i, c) = "" Then Arr(i, c) = 0
    
23.             x = Arr(i, 1)
    
24.             If Not d.exists(x) Then
    
25.                 d.Add x, Arr(i, c)
    
26.                 r = r + 1
    
27.                 ReDim Preserve rs(1 To r)  '实考人数
    
28.                 ReDim Preserve zgf(1 To r)  '最高分
    
29.                 ReDim Preserve zdf(1 To r)  '最低分
    
30.                 rs(r) = 1
    
31.                 Arr1(r, 1) = x
    
32.                 fs = d(x)
    
33.                 zgf(r) = fs
    
34.                 zdf(r) = 200
    
35.                 If fs <> 0 Then zdf(r) = fs
    
36.             Else
    
37.                 rs(r) = rs(r) + 1
    
38.                 d(x) = d(x) + Arr(i, c)
    
39.                 fs = Arr(i, c)
    
40.             End If
    
41.             Call yy
    
42.     Next
    
43.     k = d.keys
    
44.     t = d.items    '总分
    
45.     For y = 0 To UBound(k)
    
46.         Arr1(y + 1, 17) = rs(y + 1)
    
47.         Arr1(y + 1, 2) = t(y) '总分
    
48.         If rs(y + 1) - Arr1(y + 1, 16) <> 0 Then Arr1(y + 1, 3) = t(y) / (rs(y + 1) - Arr1(y + 1, 16)) '平均分
    
49.         Arr1(y + 1, 4) = zgf(y + 1) '最高分
    
50.         If zdf(y + 1) <> 200 Then
    
51.             Arr1(y + 1, 5) = zdf(y + 1) '最低分
    
52.         Else
    
53.             Arr1(y + 1, 5) = 0 '最低分
    
54.         End If
    
55.     Next
    
56.     d.RemoveAll
    
57.     With Cells(31 * j + 2, 1)
    
58.         .Value = k1(j)
    
59.         .Font.Size = 14
    
60.         .Font.ColorIndex = 5
    
61.         .Font.Bold = True
    
62.     End With
    
63.     Rows(31 * j + 2).RowHeight = 24
    
64.     With Rows(31 * j + 3)
    
65.         .RowHeight = 17.25
    
66.         .Font.Bold = True
    
67.     End With
    
68.     Cells(31 * j + 3, 1).Resize(1, 17) = bt
    
69.     Cells(31 * j + 4, 1).Resize(UBound(Arr1), 17) = Arr1
    
70.     Cells(31 * j + 31, 1) = "总计"
    
71.     Cells(31 * j + 31, 2).Formula = "=sum(r[-27]c:r[-1]c）"
    
72.     Cells(31 * j + 31, 4).Formula = "=max(r[-27]c:r[-1]c）"
    
73.     Cells(31 * j + 31, 5).Formula = "=min(r[-27]c:r[-1]c）"
    
74.     Cells(31 * j + 31, 6).Resize(1, 12).Formula = "=sum(r[-27]c:r[-1]c）"
    
75.     If Cells(31 * j + 31, 17) - Cells(31 * j + 31, 16) <> 0 Then Cells(31 * j + 31, 3) = Cells(31 * j + 31, 2) / (Cells(31 * j + 31, 17) - Cells(31 * j + 31, 16))
    
76.     Cells(31 * j + 3, 1).Resize(UBound(Arr1) + 2, 17).Borders.LineStyle = 1
    
77.     Erase Arr1
    
78. Next
    
79. End Sub

复制代码

蓝桥玄霜

请见附件。

geryjun

dyzx 发表于 2013-12-16 07:51
如果能增加“合格人数、合格率、优秀人率、优秀率”这四个项目就更好了。

这个的确有点难算，前提有几个。可以分为总分150，120，100三种。

geryjun

蓝桥玄霜 发表于 2013-12-15 13:12
请见附件。

谢谢。这就是我想要的，如果分数段加上50-59,40-49,30-39，20-29,10-29，10分以下的就更好了。

dyzx

能够增加几个项目部那就更好了。如附件

hbgydx2002

来看看蓝桥老师的代码的

mjzxlmg

dyzx 发表于 2013-12-15 17:18
能够增加几个项目部那就更好了。如附件

1. Sub test()
   
2.     Dim title(), score_1(), score_2(), i&, j&, data_in, data_out, dic As Object, m%, n%, s%, k%, ii%, jj%, iii&, jjj&
   
3.     Set dic = CreateObject("scripting.dictionary")
   
4.     title = Array("学校", "实考人数", "总分", "平均分", "最高分", "最低分")
   
5.     score_1 = Array(150, 140, 130, 120, 110, 100, 90, 80, 70, 60, 50, 40, 30, 20, 10, 0.1)
   
6.     score_2 = Array(140, 130, 120, 110, 100, 90, 80, 70, 60, 50, 40, 30, 20, 10, 0.1, 0)
   
7.     Dim tt
   
8.     tt = Timer
   
9.     Application.ScreenUpdating = False
   
10.     data_in = Sheet2.[a1].CurrentRegion.Value
    
11.     ReDim data_out(UBound(data_in), UBound(score_1) + 2 + UBound(title))
    
12.     m = 1
    
13.     n = 2
    
14.     For j = 3 To UBound(data_in, 2)
    
15.         data_out(m - 1, 0) = data_in(1, j)
    
16.         For jjj = LBound(title) To UBound(title)
    
17.             data_out(m, jjj) = title(jjj)
    
18.         Next
    
19.         For jjj = LBound(score_1) To UBound(score_1)
    
20.             data_out(m, jjj + 1 + UBound(title)) = score_2(jjj) & "~" & score_1(jjj)
    
21.         Next
    
22.         For i = 2 To UBound(data_in)
    
23.             If data_in(i, j) Then   '0分不计算实考人数，改为：If Len(data_in(i, j)) Then ,0分计算实考人数，  
    
24.                 s = dic(data_in(i, 1))
    
25.                 If s = Empty Then
    
26.                     m = m + 1
    
27.                     dic(data_in(i, 1)) = m
    
28.                     s = m
    
29.                     data_out(s, 0) = data_in(i, 1)
    
30.                     data_out(s, 4) = data_in(i, j)
    
31.                     data_out(s, 5) = data_in(i, j)
    
32.                 End If
    
33.                 data_out(s, 1) = data_out(s, 1) + 1
    
34.                 data_out(s, 2) = data_out(s, 2) + data_in(i, j)
    
35.                 data_out(s, 3) = data_out(s, 2) / data_out(s, 1)
    
36.                 If data_in(i, j) > data_out(s, 4) Then data_out(s, 4) = data_in(i, j)
    
37.                 If data_in(i, j) < data_out(s, 5) Then data_out(s, 5) = data_in(i, j)
    
38.                 For k = LBound(score_1) To UBound(score_1)
    
39.                     If data_in(i, j) >= score_2(k) And data_in(i, j) < score_1(k) Then data_out(s, UBound(title) + 1 + k) = data_out(s, UBound(title) + 1 + k) + 1
    
40.                 Next
    
41.             End If
    
42.         Next
    
43.         For jj = 1 To UBound(data_out, 2)
    
44.             For ii = n To m
    
45.                 If jj <> 3 And jj <> 4 And jj <> 5 Then data_out(m + 1, jj) = data_out(m + 1, jj) + data_out(ii, jj)
    
46.                 If jj = 4 Then
    
47.                     If data_out(m + 1, 4) = "" Then data_out(m + 1, 4) = data_out(ii, 4)
    
48.                     If data_out(ii, 4) > data_out(m + 1, 4) Then data_out(m + 1, 4) = data_out(ii, 4)
    
49.                 End If
    
50.                 If jj = 5 Then
    
51.                     If data_out(m + 1, 5) = "" Then data_out(m + 1, 5) = data_out(ii, 5)
    
52.                     If data_out(ii, 5) < data_out(m + 1, 5) Then data_out(m + 1, 5) = data_out(ii, 5)
    
53.                 End If
    
54.             Next
    
55.         Next
    
56.         data_out(m + 1, 0) = "总计"
    
57.         data_out(m + 1, 3) = data_out(m + 1, 2) / data_out(m + 1, 1)
    
58.         dic.RemoveAll
    
59.         m = m + 4
    
60.         n = m + 1
    
61.     Next
    
62.     With ActiveSheet
    
63.         .UsedRange.ClearContents
    
64.         .[a2].Resize(m + 1, UBound(data_out, 2)).Value = data_out
    
65.     End With
    
66.     Application.ScreenUpdating = True
    
67.     MsgBox Timer - tt
    
68. End Sub
    

复制代码

mjzxlmg

代码有错，要更正

geryjun

mjzxlmg 发表于 2013-12-15 22:34

谢谢，效果非常的好。