EXCEL工具程序：成绩排名
一、功能简介：
本小程序采用VB编写，可以对EXCEL数据表进行排名，主要有以下几种功能：
1、单列排名：按某一列进行排名，如成绩总分，或某一单科成绩；
2、多列排名：可以指定较复杂的排名规则，如先按总分、如并列再按语文、再按数学...；
3、多列快排：表面上与多列排名差不多，但使用了不同的算法，速度会很快。但要求参与排名的列必须是：整数、不超过3位数、指定的排名规则不超过5列；
4、分类排名：按不同学校、或不同班级排名时可使用此功能，可同时指定多个类别同时排名；
5、查找重复：按多列排名后往往能消除并列名次，但数据量很大时还会有完全同名次的情况。本功能可查找哪些名次有多少完全同名。也可对任意一列进行查找重复值并导出。
6、显示EXCEL：操作时，可显示EXCEL界面，这样就能直观地看到数据生成的情况。注意完成排名后，先隐藏EXCEL，再关闭程序，否则程序将失去操作对象。
在使用时，程序下面会显示当前操作情况和提示，一些操作也会弹出窗口提示。
程序下载：www.hnkszx.com 资料下载——工具程序——VBE03.RAR
(新浪博客好像不支持文件下载，网站也不支持直接链接下载，只能提供下载网址了)
二、程序界面：
说明：《测试数据》给出了排名次结果，第一行设为黄色的几列是程序生成的，其中：
[总分名次]是通过“单列排名”得到，可见723分第6名，出现3个并列；
[名次]：通过按“总分、语文、数学、外语、综合”顺序“多列快排”或“多列排名”得到，此时并列名次将会减少，见图中蓝色区域；
[外语名次]：单列排名生成的名次列，会命名为“XX名次”列；而多列排名生成的列号为“名次”列；
[按班级排名]、[按类别班级排名]：这2列是用“分类排名”得到，注意分类排名前应先按预定规则进行单列或多列排名、生成“名次”列，然后再按此名次来进行分类排名的。
测试数据为500行，在生成以上不同排名列中，基本上都能很快完成。但如果数据行增加到10000条，则可产生明显差异：单列排名、多列快排，也可较快完成排名；多列排名、分类排名则耗时颇多，经测试，每完成一个指定的规则列约需30秒，如果您指定了5列来进行，大概需要二三分钟才能完成。
三、附加功能：
程序附带“查找重复”功能，主要用于检查生成的名次中，是否存在并列名次，如下图：
此功能也可用于对任意一列查找重复值。当查找的列数据较长，可能在程序的列表框C中显示不下时，可以双击某行查阅。也可右击C框将全部重复值导出到一个新的EXCEL文件中查看或保存。
右击C列表框时会显示：
四、程序核心算法：
1、单列排名：使用了公式RANK
2、多列排名：第一列仍旧使用公式RANK，后续各列使用SUMPRODUCT函数，再与第一次排名生成的名次合成，逐一完成排名，最后将公式复制成值。因SUMPRODUCT函数运算量巨大，所以本功能在数据量大时会十分耗时；
3、多列快排：对于不超过3位整数、不超过5列时，先将这几列数据合成一列15位小数，再对此小数用公式RANK排名，因而速度极快，但使用自由度没有多列排名高；
4、分类排名：也是使用公式SUMPRODUCT，在名次列基本上进行运算，也很费时。
五、部分代码示例：(注意是VB代码，不是VBA)
1、单列排名时使用RANK函数：
'----------------Max_C：最大列号；Max_R：最大行号------------
XLsheet.Cells(1, Max_C + 1).Select
ActiveCell.FormulaR1C1 = List2.Text &
"名次"
Label1.Caption = "正在生成名次列，需要一定时间......"
'-------------写入第二格公式,再按最大行填充，并复制成数据-----
XLsheet.Cells(2, Max_C +
1).Select '在EXCEL单元格，公式形如：=RANK(M2,$M$2:$M$500)
ActiveCell.FormulaR1C1 = "=RANK(RC[" & Sort_C -
Max_C - 1 _
&
"],R2C" & Sort_C & ":R"
& Max_R & "C" &
Sort_C & ")"
Selection.AutoFill Destination:=Range(Cells(2, Max_C + 1),
Cells(Max_R, Max_C + 1))
Range(Cells(2, Max_C + 1), Cells(Max_R, Max_C + 1)).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPastevalues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Label1.Caption = "已按" & List2.Text
& "生成名次，正在保存......"
'----------------------保存工作薄------------------------------
Range("A1").Select
Application.Displayalerts = False
ActiveWorkbook.Save
Application.Displayalerts = True
2、多列排名时，第一列仍使用RANK函数，后续列使用SUMPRODUCT函数，下面列出程序在处理第2列及之后排名的VB代码：
'-------从指定的第2个排名列起到最后一个循环--------------
For i = 2 To List3.ListCount
Label1.Caption = "程序正在为列《" & List2.List(A(i) - 1)
& "》生成名次，操作十分耗时，CPU正在拼命运算......" _
& "如果已显示EXCEL界面，可在左下角观察运算进度。"
Label1.ForeColor = IIf(i Mod 2 = 0, vbRed, vbBlack)
Cells(2,
C2).Select
ActiveCell.FormulaR1C1 = _
"=RC[-1]+SUMPRODUCT((R2C[-1]:R" & Max_R
& "C[-1]=RC[-1])*(R2C" _
& A(i) & ":R" &
Max_R & "C" & A(i)
& ">RC" & A(i)
& "))"
'核心代码，生成单元格公式，下二句分别为VBA和EXCEL中格式，具体数据由变量替代
'"=RC[-1]+SUMPRODUCT((R2C19:R7425C19=RC19)*(R2C14:R7425C14>RC14))"
'=S2 +SUMPRODUCT(($S$2:$S$7425=$S2) *($N$2:$N$7425>$N2)) Cells(2, C2).Select
Selection.AutoFill Destination:=Range(Cells(2, C2), Cells(Max_R,
C2))
Range(Cells(2, C2), Cells(Max_R,
C2)).Select '在本列选择性粘贴速度较快
Selection.Copy
Selection.PasteSpecial Paste:=xlPastevalues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Copy '再次在复制粘贴覆盖原数据，形成新的排名数据
Cells(2,
C1).Select
ActiveSheet.Paste
Next
3、分类排名：
与多列排名相同的是：同样使用了SUMPRODUCT公式；不同的是：多列排名每次在公式中使用二个比较值相乘生成排名，再进行下一轮的公式引用。而分类排名不管几列参与排名，是一次性合成公式，参数中将有多个比较值相乘。代码如下：
Private Sub Command5_Click()
Dim
Max_R, Max_C As Integer
Dim C_MC As
Integer '名次列在第几列
Dim A() As
Integer '存放参与分类排名列的列号
Dim C1, C2
As
Integer '生成排名的列、及临时列的列号
Dim StrC1,
StrFm, StrOk As String '合成公式用字符串
On Error GoTo Openfile
If
MsgBox("分类排名：" _
& vbCrLf &
"1.数据表中必须已有《名次》列，否则请先生成《名次》列；" _
& vbCrLf &
"2.如果数据表中有多个《名次》列，则以最后一个为准；" _
& vbCrLf &
"3.参与分类排名的各列，可以是字符型、也可以是数值型；" _
& vbCrLf &
"4.指定的多个分类顺序无关，对排名结果无影响。" _
& vbCrLf &
"5.数据量大时，将比较耗时(1万记录约需半分钟)。" _
& vbCrLf & vbCrLf &
"是否继续？", vbYesNo) = vbNo Then
Exit Sub
End If
Label1.Caption = "准备开始分类排名..."
Range("A1").Select '获取行列
Max_R =
ActiveCell.SpecialCells(xlLastCell).Row '获取数据区域行列
Max_C =
ActiveCell.SpecialCells(xlLastCell).Column
C1 = Max_C +
1
For j = 1 To
Max_C
If Cells(1, j) = "名次" Then C_MC = j
Next
If C_MC = 0
Then
MsgBox "数据中没有《名次》列，无法进行分类排名！"
Exit Sub
End If
ReDim
A(List3.ListCount + 1)
For i = 1 To
List3.ListCount
xh = Split(List3.List(i - 1), vbTab)
A(i) = xh(0)
Next
StrC1 =
"按" '合成字段名字符串
StrFm =
"" '合成公式用字符串
For i = 1 To
List3.ListCount
StrC1 = StrC1 & Cells(1, A(i)).Value
StrFm = StrFm & "(R2C" & A(i)
& ":R" & Max_R &
"C" & A(i) & "=RC"
& A(i) & ")*"
Next
Cells(1, C1)
= StrC1 & "排名"
Cells(2,
C1).Select
StrOk =