[求助]急!如何用宏统计考试成绩中的各分数段人数.

office2008

全部改用数组再加循环，就是再多几个科目也无妨，加快速度

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 (160.14 KB, 下载次数: 720)

2008-9-25 19:16 上传

点击文件名下载附件

[此贴子已经被作者于2008-9-25 19:16:27编辑过]

yj304

ni57怎么不说我好学呢，哈哈！！！！，不懂就不能装懂，有时菜鸟忙3－5天，高手3－5秒，怎么不学习呢。我会继续努力，学好本领。

barlz

在这里我 学到了许多，谢谢各位

lqf57

请问61楼的老师,如何添加学科?

hupanshan

原帖由 pro123 于 2008-6-13 21:20 发表
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; cjd.Range("A1:D" & ed).Sort Key1:=cjd.Range("A1"), Order1:=xlAscending, Header:= _&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; xlGuess, OrderCustom:=1, MatchCa ...

这确实是用来排序的，是用“录制宏”方式实现的。里面很多东西我也并不很清楚，只知道这样能达到排序的目的。
cjd.Range("A1:D" & ed).Sort
cjd代表“成绩单”表，ed是求出的最末行的行数，那么这一句就是确定了排序的范围

[ 本帖最后由 hupanshan 于 2008-11-12 10:41 编辑 ]

hupanshan

原帖由 okzhengql 于 2008-7-6 09:27 发表
请问hupanshan：do while....loop 和for...next&nbsp; 有何区别，这个案例可否用 for来做？

do while 循环在所定条件不满足时退出，而for循环则是达到某一数值时结束循环。在分学校统计的时候，先取出一个校名，然后开始循环，如果运行到校名改变，就退出循环。这样的情况下，用for循环就比较难以实现。for循环本身只能计数，不好判断校名是否变了，需要增加判断校名改变的语句。因此，还是用Do While的方式简便一些。

geryjun

office2008 发表于 2008-9-25 18:09
全部改用数组再加循环，就是再多几个科目也无妨，加快速度Private Sub CommandButton1_Click()Dim i, ar'On ...

如何增加科目。谢谢。

dyzx

如果增加“参考人数、合格人数、合格率、优秀人数、优秀率”这些项目时又怎样？

gswycjc

我做了一个更为完善的，不受科目数限制，不受人数限制，不受学校数限制。欢迎使用，欢迎提出修改意见。

dyzx

gswycjc 发表于 2014-7-10 08:51
我做了一个更为完善的，不受科目数限制，不受人数限制，不受学校数限制。欢迎使用，欢迎提出修改意见。

gswycjc老师：能否增加“合格人数、合格率、优秀人数、优秀率”这些项目，请指教，多谢。