QuickSort 快速排序算法应用 返回数组第k个大小的值

香川群子

对于1个乱序的一维数组来说，要查询第k个大小的值是什么，
可以使用两种工作表函数：

1. Small
例如：=SMALL(A2:A10,4)  查询A2:A10区域中，从小到大升序时，位列第4小的值。

2. Large
例如：=LARGE(A2:B6,3)  查询A2:B6区域中，从大到小降序时，位列第3大的值。

上述工作表函数也可以直接在VBA中使用。
例如：

ar = [a1:c10]
t1 = WorksheetFunction.Small(ar, 3)
t3 = WorksheetFunction.Large(ar, 5)


…………
上述工作表函数使用方便，效率高。（无需对全部数据排序、即可得到结果。）

但是有一个缺点：只能计算数值，不能对文本进行排序比较、输出第k个大小的结果。


…………
因此，我产生了自己写一个更为通用的、不用全部排序就可直接返回第k个大小排序值的自定义函数的想法。

第1步，先写成了用于VBA内存一维数组对象、查询返回第k个大小的值的自定义函数=LargeSmall(ar,k,[z])

1. Function LargeSmall(ByVal ar, ByVal k&, Optional z& = 0)
   
2.     Dim l&, u&
   
3.     l = LBound(ar): u = UBound(ar)
   
4.     If z Then k = u - l - k + 1 Else k = l + k - 1
   
5.     LargeSmall = QuickSort2(ar, l, u, k)
   
6. End Function
   
7. Function QuickSort2(tr, l&, u&, k&)
   
8.     Dim i&, j&, r, t
   
9.     i = l: j = u: r = tr((l + u) \ 2)
   
10.     While i < j
    
11.         Do While i < u
    
12.             If tr(i) < r Then i = i + 1 Else Exit Do
    
13.         Loop
    
14.         Do While j > l
    
15.             If tr(j) > r Then j = j - 1 Else Exit Do
    
16.         Loop
    
17.         If i < j Then t = tr(i): tr(i) = tr(j): tr(j) = t: i = i + 1: j = j - 1 Else If i = j Then i = i + 1: j = j - 1
    
18.     Wend
    
19.     If k < j + 1 Then If j > l Then Call QuickSort2(tr, l, j, k)
    
20.     If k > i - 1 Then If i < u Then Call QuickSort2(tr, i, u, k)
    
21.     QuickSort2 = tr(k)
    
22. End Function

复制代码

原理是：
利用QuickSort排序算法，但仅仅比较排序到能输出第k个大小的值即可停止。这样就比完成全部排序要快。
1楼自定义函数仅能用于一维数组，4楼自定义函数改为可以兼容二维数组。

香川群子

代码应用比较：

1. Sub test()
   
2.     Dim i&
   
3.     ar = Array(2, 3, 4, 6, 7, 1, 3, 12, 16, 5, 4, 3, 3, 1, 11, 2, 3, 4, 5, 7)
   
4.     For i = 1 To UBound(ar) + 1
   
5.         t1 = WorksheetFunction.Small(ar, i)
   
6.         t2 = LargeSmall(ar, i)
   
7.         
   
8.         t3 = WorksheetFunction.Large(ar, i)
   
9.         t4 = LargeSmall(ar, i, 1)
   
10.         MsgBox i & " : " & vbCr & t1 & " vs " & t2 & vbCr & t3 & " vs " & t4
    
11.     Next
    
12. End Sub

复制代码

可知、和工作表函数一样，能够正确返回第k个大小的值。

香川群子

1. Sub test()
   
2.     Dim i&
   
3.     ar = Array("J", "A", "D", "A", "L", "T", "K", "E", "B", "M", "Z", "F", "H", "D", "N", "K", "B", "E", "A", "G")
   
4.     For i = 1 To UBound(ar) + 1
   
5.         t1 = LargeSmall(ar, i)
   
6.         t2 = LargeSmall(ar, i, 1)
   
7.         Debug.Print t1; t2
   
8.     Next
   
9. End Sub

复制代码

这是对文本值进行大小比较然后输出第k个大小值的测试。

注意，文本类型时，工作表函数的Large和Small函数无法使用！

香川群子

函数改成兼容二维版。

1. Function LargeSmall(ByVal ar, ByVal k&, Optional z& = 0)
   
2.     Dim l&, u&, l2&, u2&, k2&
   
3.     l = LBound(ar): u = UBound(ar)
   
4.     On Error GoTo 1
   
5.     l2 = LBound(ar, 2)
   
6.     u2 = UBound(ar, 2)
   
7.     ReDim tr((u - l + 1) * (u2 - l2 + 1) - 1)
   
8.     For i = l To u
   
9.         For j = l2 To u2
   
10.             tr(k2) = ar(i, j): k2 = k2 + 1
    
11.         Next
    
12.     Next
    
13.     l = LBound(tr): u = UBound(tr)
    
14.     GoTo 2
    
15. 1
    
16.     tr = ar
    
17. 2
    
18.     If z Then k = u - l - k + 1 Else k = l + k - 1
    
19.     LargeSmall = QuickSort2(tr, l, u, k)
    
20. End Function
    

复制代码

香川群子

本楼附件只是我最近回帖的清单。和主题无关。
超链接部分有错误，已经更新。
源代码来自【百度不到去谷歌】非常感谢！
http://club.excelhome.net/forum.php?mod=viewthread&tid=1127631&page=1

lee1892

有必要比较一下二叉堆

香川群子

QuickSort取第k个排序结果的算法原理：

1. 检查范围L to U (数组最小下标LBound、数组最大下标UBound)
2. 取中间位置值作为比较基准r
3. 左位置i 从L to U 以及 右位置j 从 U to L各自遍历、
    检查到比基准值大/小时即停止，左右交换一次。
4. 从停止位置继续遍历、检查、交换。
5. 左右相遇时停止
6. 递归
    如果右位置j比k大时，继续递归检查L to j
    如果左位置i比k小时，继续递归检查i to U

直到k位置超出检查范围时（即k位置部分已经排序完成），停止递归、退出。

呵呵。

和标准QuickSort唯一的不同是：
不需要完成全部递归排序、只需完成到k位置时的排序即可提前退出。
（因为本函数的目的就只需要提取第k个大小的值）

香川群子

lee1892 发表于 2014-9-12 15:24
有必要比较一下二叉堆

每次都在包含k位置的缩小范围内递归检查，感觉和二分法处理很相似的。

在不需要的部分就不再排序……

至少从结束第k个值比较计算时的角度看，也确实是一种二叉树、二叉堆的状态。

wqfzqgk

总会带来点惊喜，收藏了

木易十四

香川老师能不能在帮忙改一下您写过的代码 http://club.excelhome.net/forum.php?mod=viewthread&tid=1152 [url]http://club.excelhome.net/thread-1152880-1-1.html[/url]已发表在论坛里