全部改用数组再加循环,就是再多几个科目也无妨,加快速度 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, 下载次数: 721)
[此贴子已经被作者于2008-9-25 19:16:27编辑过] |