关于数据对比分析的源程序(含改进)
受命编写考试成绩的对比分析程序.一个下午写完,发现程序运行时间太长,竟然需要将近10分钟的时间(可能是电脑配置太低).不再过多解释,直接上程序吧,一看就知道太麻烦.
1 Option Explicit 2 Option Base 1 3 Sub A上线数据分析() 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() As Integer, km() As String, fsshu As Integer, kmshu As Integer 7 Dim arrbj() As Integer, totalC As Integer, yxrs() As Integer, zcj() 8 bj = 41 '定义班级为41个班 9 fsshu = 2 '定义分数段为26个 10 kmshu = 1 '定义科目为10科 11 12 ReDim rs(bj), yxrs(bj), fs(fsshu), mc(fsshu), km(kmshu), arrbj(bj) '重定义相应数组 13 14 km(1) = "语文" 15 ' km(2) = "数学" 16 ' km(3) = "外语" 17 ' km(4) = "物理" 18 ' km(5) = "化学" 19 ' km(7) = "政治" 20 ' km(6) = "生物" 21 ' km(8) = "历史" 22 ' km(9) = "地理" 23 ' km(10) = "总分" 24 25 mc(1) = "22" 26 mc(2) = "38" 27 ' mc(3) = "50" 28 ' mc(4) = "56" 29 ' mc(5) = "100" 30 ' mc(6) = "300" 31 ' mc(7) = "150" 32 ' mc(8) = "171" 33 ' mc(9) = "200" 34 ' mc(10) = "300" '统计后300名各班人数 35 ' mc(11) = "300" 36 ' mc(12) = "337" 37 ' mc(13) = "400" 38 ' mc(14) = "450" 39 ' mc(15) = "500" 40 ' mc(16) = "528" 41 ' mc(17) = "550" 42 ' mc(18) = "600" 43 ' mc(19) = "700" 44 ' mc(20) = "750" 45 ' mc(21) = "772" 46 ' mc(22) = "800" 47 ' mc(23) = "900" 48 ' mc(24) = "1000" 49 ' mc(25) = "1007" 50 ' mc(26) = "300" '统计后300名各班人数 51 52 '获取学生成绩所在工作表,便于下步循环使用 53 ReDim mySheet(Workbooks("pj源程序.xls").Sheets.Count) 54 For j = 1 To Workbooks("pj源程序.xls").Sheets.Count 55 mySheet(j) = Workbooks("pj源程序.xls").Sheets(j).Name 56 Next j 57 58 For j = 1 To 2 '共6张成绩表 59 Sheets(3).Activate 60 If j = 1 Then 61 With Workbooks("pj源程序.xls").Sheets(j) 62 totalR = .Range("A65536").End(xlUp).Row - 1 63 zcj() = .Range(.Cells(2, 13), .Cells(totalR + 1, 13)).Value 64 End With 65 For i = 1 To kmshu '共kmshu科,若文理分科则需修改 66 For k = 1 To fsshu '共fsshu个名次段,根据需要进行修改 67 '统计学生人数 68 69 ReDim dkcj(totalR) 70 With Workbooks("pj源程序.xls").Sheets(j) 71 dkcj() = .Range(.Cells(2, i + 3), .Cells(totalR + 1, i + 3)).Value 72 If k <= fsshu - 1 Then 73 fs(k) = Application.WorksheetFunction.Large(dkcj(), mc(k)) 74 75 For bjshu = 1 To bj '共41个班,其中附中为41班. 76 rs(bjshu) = 0 77 yxrs(bjshu) = 0 78 For m = 1 To UBound(dkcj) 79 If dkcj(m, 1) >= fs(k) And .Cells(m + 1, 1).Value = bjshu Then 80 rs(bjshu) = rs(bjshu) + 1 81 End If 82 Next m 83 Next bjshu 84 Cells(2 + (i - 1) * (UBound(rs) + 4), k + 1).Value = "前" & mc(k) '横向填充名次 85 86 Else 87 fs(k) = Application.WorksheetFunction.Small(dkcj(), mc(k)) 88 89 For bjshu = 1 To bj '共41个班,其中附中为41班. 90 rs(bjshu) = 0 91 For m = 1 To UBound(dkcj) 92 If dkcj(m, 1) <= fs(k) And .Cells(m + 1, 1).Value = bjshu Then 93 rs(bjshu) = rs(bjshu) + 1 94 End If 95 Next m 96 Next bjshu 97 Cells(2 + (i - 1) * (UBound(rs) + 4), k + 1).Value = "后" & mc(k) '横向填充名次 98 End If 99 End With 100 '纵向填充每分数段统计数据 101 Cells(3 + (i - 1) * (UBound(rs) + 4), k + 1).Resize(UBound(rs), 1).Value = Application.WorksheetFunction.Transpose(rs) 102 Next k 103 '填充对应的科目名称 104 Cells(2 + (i - 1) * (UBound(rs) + 4), 1).Value = km(i) 105 Next i 106 107 End If 108 109 '统计当前考试成绩数据 110 totalC = Range("IV2").End(xlToLeft).Column 111 If j = 2 Then 112 For i = 1 To kmshu '共kmshu科,若文理分科则需修改 113 For k = 1 To fsshu '共fsshu个名次段,根据需要进行修改 114 '统计学生人数 115 totalR = Workbooks("pj源程序.xls").Sheets(j).Range("A65536").End(xlUp).Row - 1 116 ReDim dkcj(totalR) 117 With Workbooks("pj源程序.xls").Sheets(j) 118 dkcj() = .Range(.Cells(2, i + 3), .Cells(totalR + 1, i + 3)).Value 119 If k <= fsshu - 1 Then 120 fs(k) = Application.WorksheetFunction.Large(dkcj(), mc(k)) 121 122 For bjshu = 1 To bj '共41个班,其中附中为41班. 123 rs(bjshu) = 0 124 For m = 1 To UBound(dkcj) 125 If dkcj(m, 1) >= fs(k) And .Cells(m + 1, 1).Value = bjshu Then 126 rs(bjshu) = rs(bjshu) + 1 127 End If 128 Next m 129 Next bjshu 130 131 '横向填充名次 132 Cells(2 + (i - 1) * (UBound(rs) + 4), k + totalC + 1).Value = "前" & mc(k) 133 Else 134 fs(k) = Application.WorksheetFunction.Small(dkcj(), mc(k)) 135 136 For bjshu = 1 To bj '共41个班,其中附中为41班. 137 rs(bjshu) = 0 138 For m = 1 To UBound(dkcj) 139 If dkcj(m, 1) <= fs(k) And .Cells(m + 1, 1).Value = bjshu Then 140 rs(bjshu) = rs(bjshu) + 1 141 End If 142 Next m 143 Next bjshu 144 145 '横向填充名次 146 Cells(2 + (i - 1) * (UBound(rs) + 4), k + totalC + 1).Value = "后" & mc(k) '横向填充名次 147 End If 148 End With 149 150 '纵向填充每分数段统计数据 151 Cells(3 + (i - 1) * (UBound(rs) + 4), k + totalC + 1).Resize(UBound(rs), 1).Value = Application.WorksheetFunction.Transpose(rs) 152 Next k 153 154 '填充对应的科目名称 155 Cells(2 + (i - 1) * (UBound(rs) + 4), 1).Value = km(i) 156 Next i 157 End If 158 Next j 159 160 161 '填充每科对应的班号 162 For bjshu = 1 To bj 163 arrbj(bjshu) = bjshu 164 Next bjshu 165 For i = 1 To kmshu 166 Cells(3 + (i - 1) * (UBound(rs) + 4), 1).Resize(UBound(rs), 1).Value = Application.WorksheetFunction.Transpose(arrbj) 167 Next i 168 169 '调整列宽,并打开自动刷新 170 Cells.Columns.AutoFit 171 End Sub
后来想到将需要操作的数据全部提取到数组中,然后在数组中进行比较/分析/统计,再将汇总后的数据填充到工作表中的相应位置即可.
由于需要进行对比,故需要两次考试成绩,一份用来做基数,另一份用来与之比较,套用事先规定的计算公式自动进行计算即可.
对基础数据的分析:
View Code
1 Option Base 1 2 Sub B入学成绩分析() 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() 8 bj = 41 '定义班级为41个班 9 fsshu = 6 '定义分数段为26个 10 kmshu = 10 '定义科目为10科 11 ReDim yxrs(bj), fs(fsshu), mc(fsshu), km(kmshu), arrbj(bj), zfs(fsshu) '重定义相应数组 12 mc(1) = "200" 13 mc(2) = "450" 14 mc(3) = "800" 15 mc(4) = "1600" 16 mc(5) = "2100" 17 mc(6) = "300" 18 '获得科目名称 19 For i = 1 To kmshu 20 km(i) = Workbooks("pj源程序.xls").Sheets(1).Cells(1, i + 3).Value 21 Next i 22 '将单元格数据转化成数组 23 With Workbooks("pj源程序.xls").Sheets(1) 24 totalR = .Range("A65536").End(xlUp).Row - 1 25 totalC = .Range("IV1").End(xlToLeft).Column 26 cj() = .Cells(2, 1).Resize(totalR, totalC).Value '仍要当成二维数组处理 27 End With 28 29 '定义rs的二维数组 30 ReDim rs(bj, fsshu) 31 ReDim yxrs(bj, fsshu) 32 33 For bjshu = 1 To bj 34 arrbj(bjshu) = Trim(Str(bjshu)) 35 Next bjshu 36 For i = 1 To kmshu '先科目,包括总分成绩分析,实际无意义. 37 Sheets("成绩分析").Cells(2 + (i - 1) * (bj + 7), 1).Value = km(i) '填充科目 38 Sheets("成绩分析").Cells(2 + (i - 1) * (bj + 7) + 1, 1).Resize(UBound(arrbj), 1).Value = Application.WorksheetFunction.Transpose(arrbj) 39 For k = 1 To fsshu '再分数段 40 If k < fsshu Then 41 fs(k) = Application.WorksheetFunction.Large(Application.WorksheetFunction.Index(cj(), 0, i + 3), mc(k)) 42 zfs(k) = Application.WorksheetFunction.Large(Application.WorksheetFunction.Index(cj(), 0, totalC), mc(k)) 43 For bjshu = 1 To bj 44 rs(bjshu, k) = 0 45 yxrs(bjshu, k) = 0 46 47 For m = 1 To UBound(cj) 48 If cj(m, i + 3) >= fs(k) And cj(m, 1) = bjshu Then 49 rs(bjshu, k) = rs(bjshu, k) + 1 50 End If 51 If cj(m, i + 3) >= fs(k) And cj(m, 1) = bjshu And cj(m, totalC) >= zfs(k) Then 52 yxrs(bjshu, k) = yxrs(bjshu, k) + 1 53 End If 54 Next m 55 Next bjshu 56 Sheets("成绩分析").Cells(2 + (i - 1) * (bj + 7), 2 * k).Value = "前" & mc(k) '填充名次名称 57 Sheets("成绩分析").Cells(2 + (i - 1) * (bj + 7) + 1, 2 * k).Resize(bj, 1).Value = Application.WorksheetFunction.Index(rs, 0, k) 58 Sheets("成绩分析").Cells(2 + (i - 1) * (bj + 7), 2 * k + 1).Value = "前" & mc(k) & "有效" '填充有效名次名称 59 Sheets("成绩分析").Cells(2 + (i - 1) * (bj + 7) + 1, 2 * k + 1).Resize(bj, 1).Value = Application.WorksheetFunction.Index(yxrs, 0, k) 60 End If 61 If k = fsshu Then 62 fs(k) = Application.WorksheetFunction.Small(Application.WorksheetFunction.Index(cj(), 0, i + 3), mc(k)) 63 zfs(k) = Application.WorksheetFunction.Small(Application.WorksheetFunction.Index(cj(), 0, totalC), mc(k)) 64 For bjshu = 1 To bj 65 rs(bjshu, k) = 0 66 yxrs(bjshu, k) = 0 67 68 For m = 1 To UBound(cj) 69 If cj(m, i + 3) <= fs(k) And cj(m, 1) = bjshu Then 70 rs(bjshu, k) = rs(bjshu, k) + 1 71 End If 72 If cj(m, i + 3) <= fs(k) And cj(m, 1) = bjshu And cj(m, totalC) <= zfs(k) Then 73 yxrs(bjshu, k) = yxrs(bjshu, k) + 1 74 End If 75 Next m 76 Next bjshu 77 Sheets("成绩分析").Cells(2 + (i - 1) * (bj + 7), 2 * k).Value = "后" & mc(k) '填充名次名称 78 Sheets("成绩分析").Cells(2 + (i - 1) * (bj + 7) + 1, 2 * k).Resize(bj, 1).Value = Application.WorksheetFunction.Index(rs, 0, k) 79 Sheets("成绩分析").Cells(2 + (i - 1) * (bj + 7), 2 * k + 1).Value = "后" & mc(k) & "无效" '填充有效名次名称 80 Sheets("成绩分析").Cells(2 + (i - 1) * (bj + 7) + 1, 2 * k + 1).Resize(bj, 1).Value = Application.WorksheetFunction.Index(yxrs, 0, k) 81 End If 82 Next k 83 Next i 84 85 86 87 ' '单独处理后300名各班各科及总分人数 88 ' For i = 1 To kmshu '先科目,包括总分成绩分析,实际无意义. 89 ' For k = fsshu To fsshu '再分数段 90 ' fs(k) = Application.WorksheetFunction.small(Application.WorksheetFunction.Index(cj(), 0, i + 3), mc(k)) 91 ' zfs(k) = Application.WorksheetFunction.small(Application.WorksheetFunction.Index(cj(), 0, totalC), mc(k)) 92 ' For bjshu = 1 To bj 93 ' rs(bjshu, k) = 0 94 ' yxrs(bjshu, k) = 0 95 ' 96 ' For m = 1 To UBound(cj) 97 ' If cj(m, i + 3) >= fs(k) And cj(m, 1) = bjshu Then 98 ' rs(bjshu, k) = rs(bjshu, k) + 1 99 ' End If 100 ' If cj(m, i + 3) >= fs(k) And cj(m, 1) = bjshu And cj(m, totalC) >= zfs(k) Then 101 ' yxrs(bjshu, k) = yxrs(bjshu, k) + 1 102 ' End If 103 ' Next m 104 ' Next bjshu 105 ' Sheets("成绩分析").Cells(2 + (i - 1) * (bj + 7), 2 * k).Value = "前" & mc(k) '填充名次名称 106 ' Sheets("成绩分析").Cells(2 + (i - 1) * (bj + 7) + 1, 2 * k).Resize(bj, 1).Value = Application.WorksheetFunction.Index(rs, 0, k) 107 ' Sheets("成绩分析").Cells(2 + (i - 1) * (bj + 7), 2 * k + 1).Value = "前" & mc(k) & "有效" '填充有效名次名称 108 ' Sheets("成绩分析").Cells(2 + (i - 1) * (bj + 7) + 1, 2 * k + 1).Resize(bj, 1).Value = Application.WorksheetFunction.Index(yxrs, 0, k) 109 ' Next k 110 ' Next i 111 ' 112 113 114 115 116 Sheets("成绩分析").Cells.Columns.AutoFit 117 End Sub
对发展数据的分析:(并对指定项目进一步汇总计算,以及进行一些格式设置.)
View Code
1 Option Explicit 2 Option Base 1 3 Sub C高中成线分析及后期数据处理() 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(), lshu As Integer 8 Dim Abj As Integer 9 bj = 41 '定义班级为41个班 10 Abj = 20 '定义A部班级为20个班,B部班级就可以唯一确定 11 fsshu = 6 '定义分数段为26个 12 kmshu = 10 '定义科目为10科 13 ReDim yxrs(bj), fs(fsshu), mc(fsshu), km(kmshu), arrbj(bj), zfs(fsshu) '重定义相应数组 14 mc(1) = "200" 15 mc(2) = "450" 16 mc(3) = "800" 17 mc(4) = "1600" 18 mc(5) = "2100" 19 mc(6) = "300" 20 '获得科目名称 21 For i = 1 To kmshu 22 km(i) = Workbooks("pj源程序.xls").Sheets(2).Cells(1, i + 3).Value '根据需要修改sheets(2) 23 Next i 24 '将单元格数据转化成数组 25 With Workbooks("pj源程序.xls").Sheets(2) '根据需要修改sheets(2) 26 totalR = .Range("A65536").End(xlUp).Row - 1 27 totalC = .Range("IV1").End(xlToLeft).Column 28 cj() = .Cells(2, 1).Resize(totalR, totalC).Value '仍要当成二维数组处理 29 End With 30 31 '定义rs的二维数组 32 ReDim rs(bj, fsshu) 33 ReDim yxrs(bj, fsshu) 34 lshu = Sheets("成绩分析").Range("IV2").End(xlToLeft).Column 35 36 37 For bjshu = 1 To bj 38 arrbj(bjshu) = Trim(Str(bjshu)) & "班" 39 Next bjshu 40 For i = 1 To kmshu '先科目,包括总分成线分析,实际无意义. 41 For k = 1 To fsshu '再分数段 42 If k < fsshu Then 43 fs(k) = Application.WorksheetFunction.Large(Application.WorksheetFunction.Index(cj(), 0, i + 3), mc(k)) 44 zfs(k) = Application.WorksheetFunction.Large(Application.WorksheetFunction.Index(cj(), 0, totalC), mc(k)) 45 For bjshu = 1 To bj 46 rs(bjshu, k) = 0 47 yxrs(bjshu, k) = 0 48 49 For m = 1 To UBound(cj) 50 If cj(m, i + 3) >= fs(k) And cj(m, 1) = bjshu Then 51 rs(bjshu, k) = rs(bjshu, k) + 1 52 End If 53 If cj(m, i + 3) >= fs(k) And cj(m, 1) = bjshu And cj(m, totalC) >= zfs(k) Then 54 yxrs(bjshu, k) = yxrs(bjshu, k) + 1 55 End If 56 Next m 57 Next bjshu 58 Sheets("成绩分析").Cells(2 + (i - 1) * (bj + 7), lshu + 2 * k).Value = "前" & mc(k) '填充名次名称 59 Sheets("成绩分析").Cells(2 + (i - 1) * (bj + 7) + 1, lshu + 2 * k).Resize(bj, 1).Value = Application.WorksheetFunction.Index(rs, 0, k) 60 Sheets("成绩分析").Cells(2 + (i - 1) * (bj + 7), lshu + 2 * k + 1).Value = "前" & mc(k) & "有效" '填充有效名次名称 61 Sheets("成绩分析").Cells(2 + (i - 1) * (bj + 7) + 1, lshu + 2 * k + 1).Resize(bj, 1).Value = Application.WorksheetFunction.Index(yxrs, 0, k) 62 End If 63 If k = fsshu Then 64 fs(k) = Application.WorksheetFunction.Small(Application.WorksheetFunction.Index(cj(), 0, i + 3), mc(k)) 65 zfs(k) = Application.WorksheetFunction.Small(Application.WorksheetFunction.Index(cj(), 0, totalC), mc(k)) 66 For bjshu = 1 To bj 67 rs(bjshu, k) = 0 68 yxrs(bjshu, k) = 0 69 70 For m = 1 To UBound(cj) 71 If cj(m, i + 3) <= fs(k) And cj(m, 1) = bjshu Then 72 rs(bjshu, k) = rs(bjshu, k) + 1 73 End If 74 If cj(m, i + 3) <= fs(k) And cj(m, 1) = bjshu And cj(m, totalC) <= zfs(k) Then 75 yxrs(bjshu, k) = yxrs(bjshu, k) + 1 76 End If 77 Next m 78 Next bjshu 79 Sheets("成绩分析").Cells(2 + (i - 1) * (bj + 7), lshu + 2 * k).Value = "后" & mc(k) '填充名次名称 80 Sheets("成绩分析").Cells(2 + (i - 1) * (bj + 7) + 1, lshu + 2 * k).Resize(bj, 1).Value = Application.WorksheetFunction.Index(rs, 0, k) 81 Sheets("成绩分析").Cells(2 + (i - 1) * (bj + 7), lshu + 2 * k + 1).Value = "后" & mc(k) & "无效" '填充有效名次名称 82 Sheets("成绩分析").Cells(2 + (i - 1) * (bj + 7) + 1, lshu + 2 * k + 1).Resize(bj, 1).Value = Application.WorksheetFunction.Index(yxrs, 0, k) 83 End If 84 Next k 85 Next i 86 87 88 89 90 '后期数据处理:汇总数据/计算百分比 91 '01汇总全校及各部总人数 92 93 Dim aB As Integer, bB As Integer, yZ As Integer, aBrs(), bBrs(), yZrs() 94 95 For i = 1 To kmshu 96 With Workbooks("pj源程序.xls").Sheets("成绩分析") 97 totalC = .Range("IV2").End(xlToLeft).Column 98 ReDim aBrs(totalC - 1), bBrs(totalC - 1), yZrs(totalC - 1) 99 rs() = .Cells(3 + (i - 1) * (bj + 7), 1).Resize(UBound(rs), totalC).Value 100 End With 101 102 For j = 2 To totalC 103 For k = 1 To UBound(rs) 104 If rs(k, 1) <= Abj Then 105 aB = aB + rs(k, j) 106 End If 107 108 If rs(k, 1) > Abj And rs(k, 1) < bj Then 109 bB = bB + rs(k, j) 110 End If 111 Next k 112 aBrs(j - 1) = aB 113 bBrs(j - 1) = bB 114 yZrs(j - 1) = aB + bB 115 With Workbooks("pj源程序.xls").Sheets("成绩分析") 116 .Cells(bj + 3 + (i - 1) * (bj + 7), j).Value = aBrs(j - 1) 117 .Cells(bj + 4 + (i - 1) * (bj + 7), j).Value = bBrs(j - 1) 118 .Cells(bj + 5 + (i - 1) * (bj + 7), j).Value = yZrs(j - 1) 119 End With 120 aB = 0 121 bB = 0 122 Next j 123 Sheets("成绩分析").Activate 124 Cells(bj + 3 + (i - 1) * (bj + 7), 1).Value = "A部" 125 Cells(bj + 4 + (i - 1) * (bj + 7), 1).Value = "B部" 126 Cells(bj + 5 + (i - 1) * (bj + 7), 1).Value = "一中" 127 Next i 128 129 '调整附中所在行数,若无附中成绩,则将此段代码注释掉!! 130 For i = 1 To kmshu 131 Range("A1").EntireRow.Cut 132 Cells(bj + 2 + (i - 1) * (bj + 7), 1).Value = "附中" 133 Cells(bj + 2 + (i - 1) * (bj + 7), 1).EntireRow.Cut 134 Cells(bj + 6 + (i - 1) * (bj + 7), 1).Insert Shift:=xlDown 135 Next i 136 137 '添加标题行 138 For k = 1 To kmshu 139 Cells(1 + (k - 1) * (bj + 7), 2).Resize(1, fsshu * 2).Merge 140 Cells(1 + (k - 1) * (bj + 7), 2).Value = "入学成绩" 141 Cells(1 + (k - 1) * (bj + 7), (fsshu * 2 + 2) + 1).Resize(1, fsshu * 2).Merge 142 Cells(1 + (k - 1) * (bj + 7), (fsshu * 2 + 2) + 1).Value = "2011年11月成绩" 143 Next k 144 145 '添加修饰线 146 Columns(fsshu * 2 + 2).ClearContents 147 Dim Rng1 As Range, Rng2 As Range 148 For i = 1 To kmshu 149 Set Rng1 = Cells(2 + (i - 1) * (bj + 7), 1).Resize(bj + 4, fsshu * 2 + 1) 150 Set Rng2 = Cells(2 + ((i - 1) * (bj + 7)), fsshu * 2 + 3).Resize(bj + 4, fsshu * 2) 151 Union(Rng1, Rng2).Select 152 153 Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous 154 Selection.Borders(xlEdgeTop).LineStyle = xlContinuous 155 Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous 156 Selection.Borders(xlEdgeRight).LineStyle = xlContinuous 157 Selection.Borders(xlInsideVertical).LineStyle = xlContinuous 158 Selection.Borders(xlInsideHorizontal).LineStyle = xlContinuous 159 160 Set Rng1 = Nothing 161 Set Rng2 = Nothing 162 Next i 163 164 165 166 Sheets("成绩分析").Cells.Columns.AutoFit 167 ActiveWorkbook.Save 168 End Sub
对两次数据进行对比分析,计算各项目的最终得分.
View Code
1 Option Explicit 2 3 Option Base 1 4 Sub D数据对比分析() 5 Dim i As Integer, j As Integer, mySheet() As String, k As Integer, m As Integer 6 Dim bjshu As Integer, dkcj(), totalR As Integer, fs() As Double, mc() As String 7 Dim bj As Integer, rs(), km() As String, fsshu As Integer, kmshu As Integer 8 Dim arrbj() As String, totalC As Integer, totalCc As Integer, yxrs() As Integer, cj(), zcj(), zfs(), lshu As Integer 9 Dim Abj As Integer 10 bj = 41 '定义班级为41个班 11 Abj = 20 '定义A部班级为20个班,B部班级就可以唯一确定 12 fsshu = 6 '定义分数段为26个 13 kmshu = 10 '定义科目为10科 14 ReDim yxrs(bj), fs(fsshu), mc(fsshu), km(kmshu), arrbj(bj), zfs(fsshu) '重定义相应数组 15 16 '以下为重写部分 17 totalC = Range("IV2").End(xlToLeft).Column 18 totalCc = Range("IV3").End(xlToLeft).Column 19 If totalC > totalCc Then 20 Columns(totalC).Delete 21 Columns(totalC - 1).Delete 22 MsgBox ("请重新运行程序!!") 23 Else 24 totalR = Range("A65536").End(xlUp).Row 25 Dim shu1 As Double, shu2 As Double, shu3 As Double, shu4 As Double, shu5 As Double, shu6 As Double 26 Dim myRng As Range 27 For k = 1 To kmshu 28 '单科数据对比分析,以备课组为单位进行对比. 29 Set myRng = Cells(bj + 2 + (k - 1) * (bj + 7), totalC + 1) 30 If k < kmshu Then 31 For i = 1 To 3 '对比分析三个段 32 shu1 = myRng.Offset(i - 1, -fsshu * 2) / myRng.Offset(i - 1, -(fsshu * 2 * 2 + 1)) * 0.3 33 shu2 = (myRng.Offset(i - 1, -(fsshu * 2 - 2)) - myRng.Offset(i - 1, -fsshu * 2)) / (myRng.Offset(i - 1, -(fsshu * 2 * 2 + 1 - 2)) - myRng.Offset(i - 1, -(fsshu * 2 * 2 + 1))) * 0.3 34 shu3 = (myRng.Offset(i - 1, -(fsshu * 2 - 4)) - myRng.Offset(i - 1, -(fsshu * 2 - 2))) / (myRng.Offset(i - 1, -(fsshu * 2 * 2 + 1 - 4)) - myRng.Offset(i - 1, -(fsshu * 2 * 2 + 1 - 2))) * 0.4 35 shu4 = myRng.Offset(i - 1, -(fsshu * 2 - 1)) / myRng.Offset(i - 1, -(fsshu * 2 * 2 + 1 - 1)) * 0.3 36 shu5 = (myRng.Offset(i - 1, -(fsshu * 2 - 2 - 1)) - myRng.Offset(i - 1, -(fsshu * 2 - 1))) / (myRng.Offset(i - 1, -(fsshu * 2 * 2 + 1 - 2 - 1)) - myRng.Offset(i - 1, -(fsshu * 2 * 2 + 1 - 1))) * 0.3 37 shu6 = (myRng.Offset(i - 1, -(fsshu * 2 - 4 - 1)) - myRng.Offset(i - 1, -(fsshu * 2 - 2 - 1))) / (myRng.Offset(i - 1, -(fsshu * 2 * 2 + 1 - 4 - 1)) - myRng.Offset(i - 1, -(fsshu * 2 * 2 + 1 - 2 - 1))) * 0.4 38 myRng.Offset(i - 1, 0).Value = shu1 + shu2 + shu3 39 myRng.Offset(i - 1, 1).Value = shu4 + shu5 + shu6 40 Next i 41 End If 42 Set myRng = Nothing 43 44 '总分数据对比分析,以班级/部/年级分别进行对比分析. 45 If k = kmshu Then '先按科目 46 For m = 1 To bj '后按班级 47 Set myRng = Cells(totalR - bj - 2, 1) 48 Select Case m 49 Case 1 To 12, 21 To 32 '可以改为数组来表达普通班与普通班的区别 50 shu1 = myRng.Offset(m - 1, fsshu * 4 - 4) / myRng.Offset(m - 1, fsshu * 2 - 5) * 0.4 51 shu2 = (myRng.Offset(m - 1, fsshu * 4 - 2) - myRng.Offset(m - 1, fsshu * 4 - 4)) / (myRng.Offset(m - 1, fsshu * 2 - 3) - myRng.Offset(m - 1, fsshu * 2 - 5)) * 0.5 52 shu3 = myRng.Offset(m - 1, fsshu * 2 - 1) / myRng.Offset(m - 1, fsshu * 4) * 0.1 53 myRng.Offset(m - 1, totalC).Value = shu1 + shu2 + shu3 54 Case 13 To 20, 33 To 40 55 shu1 = myRng.Offset(m - 1, fsshu * 2 + 2) / myRng.Offset(m - 1, fsshu * 2 - 11) * 0.3 56 shu2 = (myRng.Offset(m - 1, fsshu * 2 + 4) - myRng.Offset(m - 1, fsshu * 2 + 2)) / (myRng.Offset(m - 1, fsshu * 2 - 9) - myRng.Offset(m - 1, fsshu * 2 - 11)) * 0.3 57 shu3 = (myRng.Offset(m - 1, fsshu * 2 + 6) - myRng.Offset(m - 1, fsshu * 2 + 4)) / (myRng.Offset(m - 1, fsshu * 2 - 7) - myRng.Offset(m - 1, fsshu * 2 - 9)) * 0.4 58 myRng.Offset(m - 1, totalC).Value = shu1 + shu2 + shu3 59 End Select 60 Next m 61 62 For i = 1 To 3 '部及年级分析 63 If i <= 2 Then 64 shu1 = Cells(myRng.Row + bj + i - 2, fsshu * 2 + 3) / Cells(myRng.Row + bj + i - 2, fsshu * 2 - 10) * 0.3 65 shu2 = (Cells(myRng.Row + bj + i - 2, fsshu * 2 + 5) - Cells(myRng.Row + bj + i - 2, fsshu * 2 + 3)) / (Cells(myRng.Row + bj + i - 2, fsshu * 2 - 8) - Cells(myRng.Row + bj + i - 2, fsshu * 2 - 10)) * 0.3 66 shu3 = (Cells(myRng.Row + bj + i - 2, fsshu * 2 + 7) - Cells(myRng.Row + bj + i - 2, fsshu * 2 + 5)) / (Cells(myRng.Row + bj + i - 2, fsshu * 2 - 6) - Cells(myRng.Row + bj + i - 2, fsshu * 2 - 8)) * 0.35 67 shu4 = Cells(myRng.Row + bj + i - 2, fsshu * 2) / Cells(myRng.Row + bj + i - 2, fsshu * 4 + 1) * 0.05 68 Cells(myRng.Row + bj + i - 2, totalC + 1).Value = shu1 + shu2 + shu3 + shu4 69 Else 70 shu1 = Cells(myRng.Row + bj + i - 2, fsshu * 2 + 3) / Cells(myRng.Row + bj + i - 2, fsshu * 2 - 10) * 0.3 71 shu2 = (Cells(myRng.Row + bj + i - 2, fsshu * 2 + 5) - Cells(myRng.Row + bj + i - 2, fsshu * 2 + 3)) / (Cells(myRng.Row + bj + i - 2, fsshu * 2 - 8) - Cells(myRng.Row + bj + i - 2, fsshu * 2 - 10)) * 0.3 72 shu3 = (Cells(myRng.Row + bj + i - 2, fsshu * 2 + 7) - Cells(myRng.Row + bj + i - 2, fsshu * 2 + 5)) / (Cells(myRng.Row + bj + i - 2, fsshu * 2 - 6) - Cells(myRng.Row + bj + i - 2, fsshu * 2 - 8)) * 0.4 73 Cells(myRng.Row + bj + i - 2, totalC + 1).Value = shu1 + shu2 + shu3 74 End If 75 Next i 76 End If 77 Next k 78 For k = 1 To kmshu 79 Cells(2 + (k - 1) * (bj + 7), totalC + 1).Value = "上线得分" 80 Cells(2 + (k - 1) * (bj + 7), totalC + 2).Value = "有效上线得分" 81 Cells.Columns.AutoFit 82 Next k 83 84 '由于未对单科中的班级进行数据对比分析,故需删除单科中的班级所在行,以节省空间. 85 For i = totalR - bj - 3 To 1 Step -1 86 If Cells(i, 1).Value >= 1 And Cells(i, 1).Value <= bj Then 87 Rows(i).EntireRow.Delete 88 End If 89 Next i 90 Range("A2").Activate 91 End If 92 End Sub
