如何提取各班各科各分数段人数并计算级名次和班名次
以前都是在Excel中做好数据,诸如字段名,各科及总分的名次(还要用rank函数),然后再导入到VFP中进行处理,明显的效率太低,主要是来回的转化实在是烦人.现在可以在Excel中进行处理了.
先看一下原文件是如何布局的,如下图所示:
从上表中可以看出,一般拿到手的成绩表也就是这种格式(不过这里有个问题,如何把级名次和班名次添加上?刚才在网上找了一个,除了用字典,还有就是充分利用sort函数了.我以前也是用的这个方法,一会把这种方法也整理一下).现在想做的就是不改动格式的前提下,如何在另一工作表中生成各班各科及总分的各分数段人数?
源程序如下:
Sub 提取各班各科各分数段人数并计算总分级名次及班名次()
Dim i, j, k, totalR As Integer
Dim fs(12) As Double
Dim km(9) As String
Dim rs(25) As Integer
Dim mycell As Range
km(1) = "语文"
km(2) = "数学"
km(3) = "外语"
km(4) = "物理"
km(5) = "化学"
km(6) = "生物"
km(7) = "理综"
km(8) = "能力"
km(9) = "总分"
totalR = Range("A65536").End(xlUp).Row
Worksheets("sheet1").Activate
For i = 1 To 9 '按科目(9科)
For j = 1 To 12 '按名次段(12个)
For k = 1 To 25 '按班级(25个)
rs(k) = 0
fs(j) = Application.WorksheetFunction.Large(Range(Cells(2, i + 3), Cells(totalR, i + 3)), 50 + (j - 1) * 50) '利用函数Large函数提取第N个大的成绩,这样就不用再单独给某科排序,可以说省了很多事.
For Each mycell In Range(Cells(2, i + 3), Cells(totalR, i + 3)) '统计各分数段人数
If mycell.Value >= fs(j) And Cells(mycell.Row, 1).Value = k Then
rs(k) = rs(k) + 1
End If
Next mycell
Debug.Print km(i) & Str(k) & "班" & "前" & Str(50 + (j - 1) * 50) & "名分数线:" & fs(j) & "人数为:" & rs(k)
Worksheets("sheet2").Activate '填入统计出的数据
Range(Cells(1 + (i - 1) * 27, 1), Cells(1 + (i - 1) * 27, 1)).Value = km(i)
Range(Cells(1 + (i - 1) * 27, j + 1), Cells(1 + (i - 1) * 27, j + 1)).Value = "≥" + Trim(Str(fs(j)))
Range(Cells(1 + (i - 1) * 27, j + 1), Cells(1 + (i - 1) * 27, j + 1)).Offset(k, 0).Value = rs(k)
Range(Cells(1 + (i - 1) * 27, 1), Cells(1 + (i - 1) * 27, 1)).Offset(k, 0).Value = k '利用了三个变量,此种用法值得借鉴!!
Worksheets("sheet1").Activate
Next k
Next j
Next i
Worksheets("sheet2").Activate '删除文科班,利用文科班所在行的各段人数均为0,那么可以按行统计单元格为0的个数,若等于12(科目数),则必为文科班,即可以把该行删掉.
totalR = Range("A65536").End(xlUp).Row
totalC = Range("IV1").End(xlToLeft).Column
Debug.Print totalC
For i = totalR To 1 Step -1 '若从第一行开始,一旦出现了删除结果,会导致行数不对.易出现漏删现象.
If Application.WorksheetFunction.CountIf(Range(Cells(i, 1), Cells(i, totalC)), "0") = 12 Then
Range(Cells(i, 1), Cells(i, totalC)).EntireRow.Delete
End If
Next i
'计算级名次及班名次
Worksheets("sheet1").Activate
totalR = Range("A65536").End(xlUp).Row
For i = 2 To totalR '级名次为西式排名
Range(Cells(i, 13), Cells(i, 13)).Value = Application.WorksheetFunction.Rank(Range(Cells(i, 12), Cells(i, 12)), Range(Cells(2, 12), Cells(totalR, 12)))
Next i
'班名次为中式排名,由于级名次已经排完,完全可以按先班级后级名次排序,排好后,顺次填入班名次即可.
Range("A1").Sort key1:=Range("A1"), order1:=xlAscending, key2:=Range("M1"), order2:=xlAscending, header:=xlYes
'按班级填充班名次
k = 0
For i = 1 To 25
rs(i) = Application.WorksheetFunction.CountIf(Range(Cells(2, 1), Cells(totalR, 1)), Trim(Str(i)))
Debug.Print rs(i)
k = k + rs(i)
For j = 1 To rs(i)
Range(Cells(k - rs(i) + j + 1, 14), Cells(k - rs(i) + j + 1, 14)).Value = j
Next j
Next i
'上面公式中的格式应记住!!一般就是两个条件,最多三个条件.依次往下写就可以.但要注意":"的使用!!!!!!
End Sub
生成的工作表如下图所示:
计算完级名次及班名次后表格如下图所示:
反思:这样处理,可以不用管原来的名次问题.
对比:还有一个函数Percentile也可统计分数线,不过它是从百分比的角度来统计,应该也有用处的,把程序附在下面:
Sub 验证函数Percentile()
Dim s, i As Double
Dim totalR As Integer
totalR = Range("A65536").End(xlUp).Row
's = Range("IV1").End(xlToLeft).Column
Debug.Print totalR
'Range(Cells(2, 4), Cells(totalR, 4)).Select
For i = 1 To 12 '注意其中的1 - (50 + (i - 1) * 50) / totalR 的用法,此函数是按数值从小到大排序,所以通常成绩方面的前10%实际上是指后90%,这点在应用时要特别注意,下面程序行中的通过"1-"来解决这个问题.
s = Application.WorksheetFunction.Percentile(Range(Cells(2, 5), Cells(totalR, 5)), 1 - (50 + (i - 1) * 50) / totalR)
Debug.Print "前" & Str(50 + (i - 1) * 50) & "名分数线为:" & s
Range("Q2").Activate
ActiveCell.Offset(i - 1, 0).Value = "前" & Str(50 + (i - 1) * 50) & "名分数线"
ActiveCell.Offset(i - 1, 1).Value = s
ActiveCell.Columns.AutoFit
'Cells.Select
Cells.Rows.AutoFit
Next i
End Sub
今天你菊子曰了么？
