中西排名自定义函数

香川群子

【aoe1981】写了个“中国式排名的自定义函数”
http://club.excelhome.net/forum. ... 6&page=3#pid7790531


我看了以后，自己也写了一个通用排名函数：
=Rnk(Rng_Arr, Optional n_OutputIndex& = 0, Optional p_OutputMode& = 2, Optional z_SortMode& = 0)
=Rnk(范围或数组, [输出参数n],[输出模式p],[排序模式z])

一共四个参数：
参数-1： Rng_Arr 必选参数、为范围或VBA内存数组
             注意如果使用VBA内存数组，应转为一维数组后引用
             而工作表范围可以选取单行、单列，以及多行多列的矩形区域。

参数-2： n_OutputIndex 可选参数、为输出n
            默认=0时输出全部数组结果 可在单元格区域中 按下Ctrl+Shift+Cr三键返回区域数组公式结果
            否则返回第n个位置的排序结果

参数-3：p_OutputMode 可选参数、为输出模式
           
    输出模式分3种：
    p=0： 自然数序列 模式。    同分名次不并列、始终返回排序后的原始顺序(名次无间隔、最后一名一定=总人数)
    p=1： 西式排名序列 模式。 同分名次 并 列、 其余返回排序后的原始顺序(名次有间隔、最后一名 或=总人数)
    p=2： 中式排名序列 模式。 同分名次 并 列、 其余按连续顺序(名次无间隔、最后一名<=总人数)(有同分时<)
   默认p=2返回中国式排名结果

参数-4：z_SortMode 可选参数、为排序对象的排序模式
            默认z=0 即从大到小的 Z-A排序
            z=1 时  为从小到大的 A-Z排序

…………
补充：
排序对象可以是除数值以外的任意文本字符串、但会是按VBA内排序规则进行排序。
（部分可能和工作表排序顺序不同。）

另外、如果工作表引用了多行多列的矩形数组区域，
那么返回的排序结果数组仍然是一维的。

而如果要按照索引顺序来返回时，
对应规则如下：
1. 从第1行开始、从左向右列数递增，直至最大列
2. 然后从下一行开始继续、仍从左向右列数递增，直至最大列
3. 到最后一行、最后一列结束。


顺序举例如：
1、  2、  3、  4、  5；
6、  7、  8、  9、  10；
11、12、13、14、15。

香川群子

上代码、上附件：

1. Sub ArrTest()
   
2.     arr = WorksheetFunction.Transpose(Selection)
   
3.     srr = Rnk(arr)
   
4.    
   
5.     Stop
   
6. End Sub
   
7. 
   
8. Function Rnk(Rng_Arr, Optional n_OutputIndex& = 0, Optional p_OutputMode& = 2, Optional z_SortMode& = 0)
   
9.     Dim i&, t, u&
   
10.    
    
11.     On Error GoTo IsArr
    
12.     u = Rng_Arr.Count
    
13.     GoTo GetU
    
14. IsArr:
    
15.     u = UBound(Rng_Arr)
    
16. GetU:
    
17.     ReDim ar(1 To u, 1 To 2)
    
18.     For i = 1 To u
    
19.         ar(i, 1) = Rng_Arr(i)
    
20.         ar(i, 2) = i
    
21.     Next
    
22.     Call ShellSortArr(ar, 1, 2, u, z_SortMode) 'Sort by Score or TextValue (Column 1)
    
23.    
    
24.     If p_OutputMode = 0 Then 'Nature Sequence Rank
    
25.         For i = 1 To u
    
26.             ar(i, 1) = i
    
27.         Next
    
28.     ElseIf p_OutputMode = 1 Then 'West Rank
    
29.         t = ar(1, 1): ar(1, 1) = 1
    
30.         For i = 2 To u
    
31.             If ar(i, 1) = t Then ar(i, 1) = ar(i - 1, 1) Else t = ar(i, 1): ar(i, 1) = i
    
32.         Next
    
33.     ElseIf p_OutputMode = 2 Then 'Chinese Rank
    
34.         t = ar(1, 1): k = 1: ar(1, 1) = 1
    
35.         For i = 2 To u
    
36.             If ar(i, 1) <> t Then t = ar(i, 1): k = k + 1
    
37.             ar(i, 1) = k
    
38.         Next
    
39.     End If
    
40.    
    
41.     Call ShellSortArr(ar, 2, 1, u, 1) 'Sort back by Sequence No (Column 2)
    
42.    
    
43.     If n_OutputIndex = 0 Then Rnk = Application.Index(ar, , 1) Else Rnk = ar((n_OutputIndex - 1) Mod u + 1, 1)
    
44.    
    
45. End Function
    
46. Sub ShellSortArr(tr, x&, y&, u&, Optional z_SortMode& = 0) 'QuickShellSort
    
47.     Dim h&, i&, j&, k&, t1, t2
    
48.     h = u
    
49.     Do
    
50.         h = (h \ 5) * 2 + 1
    
51.         For i = h + 1 To u
    
52.             t1 = tr(i, x): t2 = tr(i, y)
    
53.             For j = i - h To 1 Step -h
    
54.                 If z_SortMode Then
    
55.                     If tr(j, x) < t1 Then Exit For 'z_SortMode=1 A-Z Sort
    
56.                 Else
    
57.                     If tr(j, x) > t1 Then Exit For 'z_SortMode=0 Z-A Sort
    
58.                 End If
    
59.                 tr(j + h, x) = tr(j, x): tr(j + h, y) = tr(j, y)
    
60.             Next
    
61.             tr(j + h, x) = t1: tr(j + h, y) = t2
    
62.         Next
    
63.     Loop Until h = 1
    
64. End Sub
    

复制代码

香川群子

使用了希尔快速排序。但没有使用分组参数，而是采用了5整除的2倍加1的计算取值方法。

如对工作表多行、多列内容排序，则参考顺序为：
1. 从第1行开始、从左到右遍历各列；
2. 移到下一行继续从左到右遍历各列、直至全部区域结束。

另外，排序对象可以是数值、以及任意字符串对象。
而工作表函数=RANK()仅能对数值进行西式排序。

呵呵。

ni57

好东西，谢谢楼主

aoe1981

豁，您这是刚写的大作呀，我以为是老帖了，还觉得自己拿来主义没有练好了……

aoe1981

香川群子 发表于 2014-8-6 13:33
上代码、上附件：

功能如此强大，除去空行代码只有58行，太简短了，不服不行啊……除去测试引用自定义函数部分，实际代码52行！！！

aoe1981

目前首先给我的感觉是这个第2参数很牛！能够返回第n个值，避免了非要区域数组公式的方法进行输入，符合多数函数的输入使用方法，你整一个所谓“区域数组公式”，有时候着急了，半天弄不到正确的结果，人也懒得用了……事实上，我的自定义函数返回结果时究竟是个什么样的情况，我自己也不敢确定，而是在工作表中把几种公式输入方式挨个试了以后才知道的……

香川群子

aoe1981 发表于 2014-8-6 14:01
豁，您这是刚写的大作呀，我以为是老帖了，还觉得自己拿来主义没有练好了……

呵呵，看了你的中国式排名自定义函数，感觉不过瘾……


要改就觉得除了 Function 和 End Function 以外，没啥特别的保留价值……不如重新写。呵呵。

于是花点时间现写了一个。顺手就把自然排名、西式排名、中式排名3种方式一起完成了。

aoe1981

香川群子 发表于 2014-8-6 15:14
呵呵，看了你的中国式排名自定义函数，感觉不过瘾……

我为这两句：“ Function 和 End Function”感到由衷地自豪！
呵呵……

香川群子

aoe1981 发表于 2014-8-6 14:18
功能如此强大，除去空行代码只有58行，太简短了，不服不行啊……除去测试引用自定义函数部分，实际代码52 ...

2楼代码及附件，是可以对任意对象（数值或文本）进行排序的通用代码。


如果仅仅是针对数值（可含小数）排序，那么代码如下：

1. Function Rnk2(Rng_Arr, Optional n& = 0, Optional p& = 2, Optional z& = 0, Optional m& = 100, Optional d& = 0)
   
2.     Dim i&, j&, r, s, t&, u&
   
3. 
   
4.     ReDim a((m + 1) * 10 ^ d) '确保最大值能被包含。默认不含负数。
   
5.     For Each r In Rng_Arr
   
6.         i = i + 1: t = r * 10 ^ d: a(t) = a(t) & "," & i
   
7.     Next
   
8.     b = Filter(a, ",", True) '提取全部已排序有效数据
   
9. 
   
10.     ReDim c(1 To i): ReDim k&(2)
    
11.     If z = 1 Then i = -1: u = UBound(b) Else z = -1: i = UBound(b) + 1: u = 0
    
12.     Do
    
13.         i = i + z: s = Split(b(i), ",")
    
14.         k(1) = k(0) + 1: k(2) = k(2) + 1
    
15.         For j = 1 To UBound(s)
    
16.             k(0) = k(0) + 1: c(s(j)) = k(p)
    
17.         Next
    
18.     Loop Until i = u
    
19. 
    
20.     If n > 0 Then Rnk2 = c(n) Else If n = 0 Then Rnk2 = WorksheetFunction.Transpose(c) Else Rnk2 = c
    
21. 
    
22. End Function

复制代码

其中，增加了第5、第6参数：
第5参数m： 排序对象中数值的最大值，目前默认设置=100分。
  可以自行修改成其他常用数值，如500，或每次调用函数时，用Max函数取得最大值来输入。

第6参数d： 小数位设置。 用法参照 =Round()的第2参数。
默认d=0 即按整数处理。如有2位小数则设置d=2即可。



呵呵。
追加：
第2参数 n 可以设置为三种状态：
n>0 则返回第n个位置对象的排序名次结果
n=0 则以多行单列的形式【即c(i,1)格式】返回全部结果的数组，以便在多行单列区域中作为数组三键公式使用。
n<0 则以单行多列的形式【即c(1,j)格式】返回全部结果的数组，以便在单行多列区域中作为数组三键公式使用。