关于考试成绩分析与处理程序的最新改进
前面已经写过两个成绩处理程序了,但运行速度实在太慢,处理一个年级的成绩约需5分钟,根本没法体会到在VFP中的那种快感,现在又重新改写了原程序,在前面编写学分认定的程序时,慢慢体会到了在VBA中应用数组的方便与简洁,所以这次出发点从数组的角度考虑问题.
由于没做界面所以也没法让用户(其实用户就是我自己)选择,只能做一点点的硬性要求:将原始成绩放置到第1个工作表,第1列必须是班级号,从第4列起为依次为单科和总分成绩,(第2列/第3列为姓名/考试号).工作表的名称随便起,存储成绩分析的工作表名字必须为"成绩分析",否则报错.
以下是源程序:
1 Option Base 1 2 Sub E单独处理学生成绩不作对比() 3 Sheets("成绩分析").Cells.Delete 4 Dim i As Integer, j As Integer, mySheet() As String, k As Integer, m As Integer 5 Dim bjshu As Integer, dkcj(), totalR As Integer, fs() As Double, mc() As String 6 Dim bj As Integer, rs(), km() As String, fsshu As Integer, kmshu As Integer 7 Dim arrbj() As String, totalC As Integer, yxrs() As Integer, cj(), zcj(), zfs(), Abj As Integer 8 bj = 38 '定义班级为41个班, 9 Abj = 20 '定义A部班级为20个班,B部班级就可以唯一确定 10 fsshu = 4 '定义分数段为26个 11 kmshu = 7 '定义科目为10科 12 ReDim yxrs(bj), fs(fsshu), mc(fsshu), km(kmshu), arrbj(bj), zfs(fsshu) '重定义相应数组 13 mc(1) = "10" 14 mc(2) = "50" 15 mc(3) = "100" 16 mc(4) = "600" 17 '获得科目名称 18 For i = 1 To kmshu 19 km(i) = Workbooks("pj源程序.xls").Sheets(1).Cells(1, i + 3).Value 20 Next i 21 '将单元格数据转化成数组 22 With Workbooks("pj源程序.xls").Sheets(1) 23 totalR = .Range("A65536").End(xlUp).Row - 1 24 totalC = .Range("IV1").End(xlToLeft).Column 25 cj() = .Cells(2, 1).Resize(totalR, totalC).Value '仍要当成二维数组处理 26 End With 27 28 '定义rs的二维数组 29 ReDim rs(bj, fsshu) 30 ReDim yxrs(bj, fsshu) 31 32 For bjshu = 1 To bj 33 arrbj(bjshu) = Trim(Str(bjshu)) 34 Next bjshu 35 For i = 1 To kmshu '先科目,包括总分成绩分析,实际无意义. 36 Sheets("成绩分析").Cells(2 + (i - 1) * (bj + 7), 1).Value = km(i) '填充科目 37 Sheets("成绩分析").Cells(2 + (i - 1) * (bj + 7) + 1, 1).Resize(UBound(arrbj), 1).Value = Application.WorksheetFunction.Transpose(arrbj) 38 For k = 1 To fsshu '再分数段 39 fs(k) = Application.WorksheetFunction.Large(Application.WorksheetFunction.Index(cj(), 0, i + 3), mc(k)) 40 zfs(k) = Application.WorksheetFunction.Large(Application.WorksheetFunction.Index(cj(), 0, totalC), mc(k)) 41 For bjshu = 1 To bj 42 rs(bjshu, k) = 0 43 yxrs(bjshu, k) = 0 44 45 For m = 1 To UBound(cj) 46 If cj(m, i + 3) >= fs(k) And cj(m, 1) = bjshu Then 47 rs(bjshu, k) = rs(bjshu, k) + 1 48 End If 49 If cj(m, i + 3) >= fs(k) And cj(m, 1) = bjshu And cj(m, totalC) >= zfs(k) Then 50 yxrs(bjshu, k) = yxrs(bjshu, k) + 1 51 End If 52 Next m 53 Next bjshu 54 Sheets("成绩分析").Cells(2 + (i - 1) * (bj + 7), 2 * k).Value = "前" & mc(k) '填充名次名称 55 Sheets("成绩分析").Cells(2 + (i - 1) * (bj + 7) + 1, 2 * k).Resize(bj, 1).Value = Application.WorksheetFunction.Index(rs, 0, k) 56 Sheets("成绩分析").Cells(2 + (i - 1) * (bj + 7), 2 * k + 1).Value = "前" & mc(k) & "有效" '填充有效名次名称 57 Sheets("成绩分析").Cells(2 + (i - 1) * (bj + 7) + 1, 2 * k + 1).Resize(bj, 1).Value = Application.WorksheetFunction.Index(yxrs, 0, k) 58 Next k 59 Next i 60 61 62 63 '后期处理数据,汇总各部各校人数 64 Dim aB As Integer, bB As Integer, yZ As Integer, aBrs(), bBrs(), yZrs() 65 66 For i = 1 To kmshu 67 With Workbooks("pj源程序.xls").Sheets("成绩分析") 68 totalC = .Range("IV2").End(xlToLeft).Column 69 ReDim aBrs(totalC - 1), bBrs(totalC - 1), yZrs(totalC - 1) 70 rs() = .Cells(3 + (i - 1) * (bj + 7), 1).Resize(UBound(rs), totalC).Value 71 End With 72 73 For j = 2 To totalC 74 For k = 1 To UBound(rs) 75 If rs(k, 1) <= Abj Then 76 aB = aB + rs(k, j) 77 End If 78 79 If rs(k, 1) > Abj And rs(k, 1) <= bj Then '此处若无附中成绩则需将<jb改为<=bj 80 bB = bB + rs(k, j) 81 End If 82 Next k 83 aBrs(j - 1) = aB 84 bBrs(j - 1) = bB 85 yZrs(j - 1) = aB + bB 86 With Workbooks("pj源程序.xls").Sheets("成绩分析") 87 .Cells(bj + 3 + (i - 1) * (bj + 7), j).Value = aBrs(j - 1) 88 .Cells(bj + 4 + (i - 1) * (bj + 7), j).Value = bBrs(j - 1) 89 .Cells(bj + 5 + (i - 1) * (bj + 7), j).Value = yZrs(j - 1) 90 End With 91 aB = 0 92 bB = 0 93 Next j 94 Sheets("成绩分析").Activate 95 Cells(bj + 3 + (i - 1) * (bj + 7), 1).Value = "A部" 96 Cells(bj + 4 + (i - 1) * (bj + 7), 1).Value = "B部" 97 Cells(bj + 5 + (i - 1) * (bj + 7), 1).Value = "一中" 98 Next i 99 100 ' '调整附中所在行数,若无附中成绩,则将此段代码注释掉!! 101 ' For i = 1 To kmshu 102 ' Range("A1").EntireRow.Cut 103 ' Cells(bj + 2 + (i - 1) * (bj + 7), 1).Value = "附中" 104 ' Cells(bj + 2 + (i - 1) * (bj + 7), 1).EntireRow.Cut 105 ' Cells(bj + 6 + (i - 1) * (bj + 7), 1).Insert Shift:=xlDown 106 ' Next i 107 108 '添加修饰线 109 Cells(1, fsshu * 2 + 2).EntireColumn.ClearContents 110 Dim Rng1 As Range, Rng2 As Range 111 112 For i = 1 To kmshu 113 Set Rng1 = Cells(2 + (i - 1) * (bj + 7), 1).Resize(bj + 4, fsshu * 2 + 1) 114 Rng1.Select 115 116 Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous 117 Selection.Borders(xlEdgeTop).LineStyle = xlContinuous 118 Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous 119 Selection.Borders(xlEdgeRight).LineStyle = xlContinuous 120 Selection.Borders(xlInsideVertical).LineStyle = xlContinuous 121 Selection.Borders(xlInsideHorizontal).LineStyle = xlContinuous 122 123 Set Rng1 = Nothing 124 Set Rng2 = Nothing 125 Next i 126 Range("A2").Activate 127 '将各项均为零的行删掉,因为这些行肯定是非本科类的班级 128 '由于未对单科中的班级进行数据对比分析,故需删除单科中的班级所在行,以节省空间. 129 For i = totalR To 1 Step -1 130 If Application.WorksheetFunction.CountIf(Cells(i, 1).Resize(1, totalC), 0) = fsshu * 2 Then 131 Rows(i).EntireRow.Delete 132 End If 133 Next i 134 135 Sheets("成绩分析").Cells.Columns.AutoFit 136 End Sub
运行过程只需5秒即可,已经超乎我的想像了,想想以前写的代码,真是让人汗颜啊,看着屏幕来回的闪,大半天不结束,让人感觉还不如手动操作来的快.现在可以有一点点的骄傲.
不过让人比较郁闷的是一句话抹杀了自己辛辛苦苦5天的成果,感觉自己简单就是个大笨蛋,这么简单的事情都不能在1分钟内做出来,还好意思表功啊!!没讥讽你就不错了.
