关于数据对比分析的源程序(含改进)

受命编写考试成绩的对比分析程序.一个下午写完,发现程序运行时间太长,竟然需要将近10分钟的时间(可能是电脑配置太低).不再过多解释,直接上程序吧,一看就知道太麻烦.

Option Explicit
Option Base 1
Sub A上线数据分析()
Dim i As Integer, j As Integer, mySheet() As String, k As Integer, m As Integer
Dim bjshu As Integer, dkcj(), totalR As Integer, fs() As Double, mc() As String
Dim bj As Integer, rs() As Integer, km() As String, fsshu As Integer, kmshu As Integer
Dim arrbj() As Integer, totalC As Integer, yxrs() As Integer, zcj()
bj = 41 '定义班级为41个班
fsshu = 2 '定义分数段为26个
kmshu = 1 '定义科目为10科

ReDim rs(bj), yxrs(bj), fs(fsshu), mc(fsshu), km(kmshu), arrbj(bj) '重定义相应数组

km(1) = "语文"
'    km(2) = "数学"
'    km(3) = "外语"
'    km(4) = "物理"
'    km(5) = "化学"
'    km(7) = "政治"
'    km(6) = "生物"
'    km(8) = "历史"
'    km(9) = "地理"
'    km(10) = "总分"

mc(1) = "22"
mc(2) = "38"
'    mc(3) = "50"
'    mc(4) = "56"
'    mc(5) = "100"
'    mc(6) = "300"
'    mc(7) = "150"
'    mc(8) = "171"
'    mc(9) = "200"
'    mc(10) = "300" '统计后300名各班人数
'    mc(11) = "300"
'    mc(12) = "337"
'    mc(13) = "400"
'    mc(14) = "450"
'    mc(15) = "500"
'    mc(16) = "528"
'    mc(17) = "550"
'    mc(18) = "600"
'    mc(19) = "700"
'    mc(20) = "750"
'    mc(21) = "772"
'    mc(22) = "800"
'    mc(23) = "900"
'    mc(24) = "1000"
'    mc(25) = "1007"
'    mc(26) = "300" '统计后300名各班人数

'获取学生成绩所在工作表,便于下步循环使用
ReDim mySheet(Workbooks("pj源程序.xls").Sheets.Count)
For j = 1 To Workbooks("pj源程序.xls").Sheets.Count
mySheet(j) = Workbooks("pj源程序.xls").Sheets(j).Name
Next j

For j = 1 To 2 '共6张成绩表
Sheets(3).Activate
If j = 1 Then
With Workbooks("pj源程序.xls").Sheets(j)
totalR = .Range("A65536").End(xlUp).Row - 1
zcj() = .Range(.Cells(2, 13), .Cells(totalR + 1, 13)).Value
End With
For i = 1 To kmshu '共kmshu科,若文理分科则需修改
For k = 1 To fsshu '共fsshu个名次段,根据需要进行修改
'统计学生人数

ReDim dkcj(totalR)
With Workbooks("pj源程序.xls").Sheets(j)
dkcj() = .Range(.Cells(2, i + 3), .Cells(totalR + 1, i + 3)).Value
If k <= fsshu - 1 Then
fs(k) = Application.WorksheetFunction.Large(dkcj(), mc(k))

For bjshu = 1 To bj '共41个班,其中附中为41班.
rs(bjshu) = 0
yxrs(bjshu) = 0
For m = 1 To UBound(dkcj)
If dkcj(m, 1) >= fs(k) And .Cells(m + 1, 1).Value = bjshu Then
rs(bjshu) = rs(bjshu) + 1
End If
Next m
Next bjshu
Cells(2 + (i - 1) * (UBound(rs) + 4), k + 1).Value = "前" & mc(k) '横向填充名次

Else
fs(k) = Application.WorksheetFunction.Small(dkcj(), mc(k))

For bjshu = 1 To bj '共41个班,其中附中为41班.
rs(bjshu) = 0
For m = 1 To UBound(dkcj)
If dkcj(m, 1) <= fs(k) And .Cells(m + 1, 1).Value = bjshu Then
rs(bjshu) = rs(bjshu) + 1
End If
Next m
Next bjshu
Cells(2 + (i - 1) * (UBound(rs) + 4), k + 1).Value = "后" & mc(k) '横向填充名次
End If
End With
'纵向填充每分数段统计数据
Cells(3 + (i - 1) * (UBound(rs) + 4), k + 1).Resize(UBound(rs), 1).Value = Application.WorksheetFunction.Transpose(rs)
Next k
'填充对应的科目名称
Cells(2 + (i - 1) * (UBound(rs) + 4), 1).Value = km(i)
Next i

End If

'统计当前考试成绩数据
totalC = Range("IV2").End(xlToLeft).Column
If j = 2 Then
For i = 1 To kmshu '共kmshu科,若文理分科则需修改
For k = 1 To fsshu '共fsshu个名次段,根据需要进行修改
'统计学生人数
totalR = Workbooks("pj源程序.xls").Sheets(j).Range("A65536").End(xlUp).Row - 1
ReDim dkcj(totalR)
With Workbooks("pj源程序.xls").Sheets(j)
dkcj() = .Range(.Cells(2, i + 3), .Cells(totalR + 1, i + 3)).Value
If k <= fsshu - 1 Then
fs(k) = Application.WorksheetFunction.Large(dkcj(), mc(k))

For bjshu = 1 To bj '共41个班,其中附中为41班.
rs(bjshu) = 0
For m = 1 To UBound(dkcj)
If dkcj(m, 1) >= fs(k) And .Cells(m + 1, 1).Value = bjshu Then
rs(bjshu) = rs(bjshu) + 1
End If
Next m
Next bjshu

'横向填充名次
Cells(2 + (i - 1) * (UBound(rs) + 4), k + totalC + 1).Value = "前" & mc(k)
Else
fs(k) = Application.WorksheetFunction.Small(dkcj(), mc(k))

For bjshu = 1 To bj '共41个班,其中附中为41班.
rs(bjshu) = 0
For m = 1 To UBound(dkcj)
If dkcj(m, 1) <= fs(k) And .Cells(m + 1, 1).Value = bjshu Then
rs(bjshu) = rs(bjshu) + 1
End If
Next m
Next bjshu

'横向填充名次
Cells(2 + (i - 1) * (UBound(rs) + 4), k + totalC + 1).Value = "后" & mc(k) '横向填充名次
End If
End With

'纵向填充每分数段统计数据
Cells(3 + (i - 1) * (UBound(rs) + 4), k + totalC + 1).Resize(UBound(rs), 1).Value = Application.WorksheetFunction.Transpose(rs)
Next k

'填充对应的科目名称
Cells(2 + (i - 1) * (UBound(rs) + 4), 1).Value = km(i)
Next i
End If
Next j

'填充每科对应的班号
For bjshu = 1 To bj
arrbj(bjshu) = bjshu
Next bjshu
For i = 1 To kmshu
Cells(3 + (i - 1) * (UBound(rs) + 4), 1).Resize(UBound(rs), 1).Value = Application.WorksheetFunction.Transpose(arrbj)
Next i

'调整列宽,并打开自动刷新
Cells.Columns.AutoFit
End Sub

后来想到将需要操作的数据全部提取到数组中,然后在数组中进行比较/分析/统计,再将汇总后的数据填充到工作表中的相应位置即可.
由于需要进行对比,故需要两次考试成绩,一份用来做基数,另一份用来与之比较,套用事先规定的计算公式自动进行计算即可.

对基础数据的分析:

View Code

Option Explicit

Option Base 1
Sub D数据对比分析()
Dim i As Integer, j As Integer, mySheet() As String, k As Integer, m As Integer
Dim bjshu As Integer, dkcj(), totalR As Integer, fs() As Double, mc() As String
Dim bj As Integer, rs(), km() As String, fsshu As Integer, kmshu As Integer
Dim arrbj() As String, totalC As Integer, totalCc As Integer, yxrs() As Integer, cj(), zcj(), zfs(), lshu As Integer
Dim Abj As Integer
bj = 41 '定义班级为41个班
Abj = 20 '定义A部班级为20个班,B部班级就可以唯一确定
fsshu = 6 '定义分数段为26个
kmshu = 10 '定义科目为10科
ReDim yxrs(bj), fs(fsshu), mc(fsshu), km(kmshu), arrbj(bj), zfs(fsshu)  '重定义相应数组

'以下为重写部分
totalC = Range("IV2").End(xlToLeft).Column
totalCc = Range("IV3").End(xlToLeft).Column
If totalC > totalCc Then
Columns(totalC).Delete
Columns(totalC - 1).Delete
MsgBox ("请重新运行程序!!")
Else
totalR = Range("A65536").End(xlUp).Row
Dim shu1 As Double, shu2 As Double, shu3 As Double, shu4 As Double, shu5 As Double, shu6 As Double
Dim myRng As Range
For k = 1 To kmshu
'单科数据对比分析,以备课组为单位进行对比.
Set myRng = Cells(bj + 2 + (k - 1) * (bj + 7), totalC + 1)
If k < kmshu Then
For i = 1 To 3 '对比分析三个段
shu1 = myRng.Offset(i - 1, -fsshu * 2) / myRng.Offset(i - 1, -(fsshu * 2 * 2 + 1)) * 0.3
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
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
shu4 = myRng.Offset(i - 1, -(fsshu * 2 - 1)) / myRng.Offset(i - 1, -(fsshu * 2 * 2 + 1 - 1)) * 0.3
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
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
myRng.Offset(i - 1, 0).Value = shu1 + shu2 + shu3
myRng.Offset(i - 1, 1).Value = shu4 + shu5 + shu6
Next i
End If
Set myRng = Nothing

'总分数据对比分析,以班级/部/年级分别进行对比分析.
If k = kmshu Then '先按科目
For m = 1 To bj '后按班级
Set myRng = Cells(totalR - bj - 2, 1)
Select Case m
Case 1 To 12, 21 To 32 '可以改为数组来表达普通班与普通班的区别
shu1 = myRng.Offset(m - 1, fsshu * 4 - 4) / myRng.Offset(m - 1, fsshu * 2 - 5) * 0.4
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
shu3 = myRng.Offset(m - 1, fsshu * 2 - 1) / myRng.Offset(m - 1, fsshu * 4) * 0.1
myRng.Offset(m - 1, totalC).Value = shu1 + shu2 + shu3
Case 13 To 20, 33 To 40
shu1 = myRng.Offset(m - 1, fsshu * 2 + 2) / myRng.Offset(m - 1, fsshu * 2 - 11) * 0.3
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
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
myRng.Offset(m - 1, totalC).Value = shu1 + shu2 + shu3
End Select
Next m

For i = 1 To 3 '部及年级分析
If i <= 2 Then
shu1 = Cells(myRng.Row + bj + i - 2, fsshu * 2 + 3) / Cells(myRng.Row + bj + i - 2, fsshu * 2 - 10) * 0.3
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
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
shu4 = Cells(myRng.Row + bj + i - 2, fsshu * 2) / Cells(myRng.Row + bj + i - 2, fsshu * 4 + 1) * 0.05
Cells(myRng.Row + bj + i - 2, totalC + 1).Value = shu1 + shu2 + shu3 + shu4
Else
shu1 = Cells(myRng.Row + bj + i - 2, fsshu * 2 + 3) / Cells(myRng.Row + bj + i - 2, fsshu * 2 - 10) * 0.3
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
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
Cells(myRng.Row + bj + i - 2, totalC + 1).Value = shu1 + shu2 + shu3
End If
Next i
End If
Next k
For k = 1 To kmshu
Cells(2 + (k - 1) * (bj + 7), totalC + 1).Value = "上线得分"
Cells(2 + (k - 1) * (bj + 7), totalC + 2).Value = "有效上线得分"
Cells.Columns.AutoFit
Next k

'由于未对单科中的班级进行数据对比分析,故需删除单科中的班级所在行,以节省空间.
For i = totalR - bj - 3 To 1 Step -1
If Cells(i, 1).Value >= 1 And Cells(i, 1).Value <= bj Then
Rows(i).EntireRow.Delete
End If
Next i
Range("A2").Activate
End If
End Sub