vba二维数组多key稳定排序
此代码为Excel Home论坛的香川裙子所做，经测试，效果不错。szpx函数返回的是一个一维数组，下标从1开始，里面记录的是原数组的行，直接调用即可。
比如：如数据arr是100行，7列的数组，排序给brr=szpx(arr,0,1,2),数组brr是brr(1)~brr(100),里面记录的是排序后原来数组的序号。（有点绕，好好理解下）
如果无法理解上面的话，用szbr输出排序后的数组即可。因为大多数时候没有必要输出数组，直接根据szpx后的结果在arr中取该值即可。
下面是改排序在mqcal工程算量中辅助输入的应用：（查找数据后排序）
Sub test1px() '【二维数组多key稳定排序】的应用示例 Dim ar, br, nr, sr, h&, i&, j&, m&, n&, r&, tms# m = 20000: n = 7 ReDim a(1 To m, 1 To n) For i = 1 To m a(i, 1) = i For j = 2 To n r = Int(Rnd * 10): If r Then a(i, j) = r Next Next ar = a '以上生成m行n列的VBA内存二维数组 ' ar = [k1].CurrentRegion.Value '也可直接读取工作表区域得到二维数组 sr = Array(3, 1, 5, 2, 7, 1) '按权重优先顺序key、Sort值交替排列的一维数组。key为列序号、Sort值：1升序、2降序 ' sr = Array(3, -1, 5, 2, 7, -1)'Sort值=-1时，升序并且空值会在最前面。(Sort=1时按工作表排序方法空值排在最后) 'Sort值=2时、降序而空值自然会在最后。 tms = Timer nr = szpx(ar, 0, sr) '第1参数为待排序二维数组、第2参数为不参与排序的标题行的行数 '第3参数为按权重优先顺序key、Sort值交替排列的一维数组。 Debug.Print "Sort1: " & Format(Timer - tms, "0.00s ") & "Sort" ' nr = szpx(ar, 0, 3, 1, 5, 2, 7, 1) '也可这样写入参数。从第3个参数开始交替写入key、Sort值。推荐第1种写法。 ' Exit Sub ' 下面是返回排序后数组结果?并输出到工作表的代码 br = szbr(ar, nr, 0): [k1].Resize(UBound(br) - LBound(br) + 1, UBound(br, 2) - LBound(br, 2) + 1) = br End Sub Function szpx(ar, h&, ParamArray sr()) 'by kagawa 2015/12/4-12/7 主要参考借鉴了Zamyi大侠的二维数组多key排序算法 '第1参数ar：为待排序二维数组、第2参数h：为不参与排序的标题行的行数 '第3参数sr：为按权重优先顺序key、Sort值交替排列的一维数组、或以逗号分隔直接写入Key、Sort值。 Dim br, y, sr2, i&, i2&, i3&, i4&, j&, j2&, k&, l&, u&, s&, t l = LBound(ar) + h: u = UBound(ar) '获取数组起始、结束位置 ReDim x&(l To u), z(l To u + 1) As Boolean '定义存放Index序号的数组x、标记段落结束位置的数组z For i = l To u x(i) = i 'Index赋值为数组行序号、这以后排序就只需改变这个Index位置、原始数组无需改变 Next z(u + 1) = True '标记最后结束位置 If UBound(sr) = 0 Then sr2 = sr(0) Else sr2 = sr '判断第3参数是数组、还是多Key、Sort值序列 j = sr2(0): If sr2(1) Mod 2 Then Call QuickSort1(ar, x, j, l, u) Else Call QuickSort2(ar, x, j, l, u) '按key1先进行QuickSort排序 If sr2(1) = 1 Then Call AZE(ar, x, j, l, u) '如果Sort值=1则需要调用AZE过程、把空值移动到最后 For k = 2 To UBound(sr2) Step 2 '接着循环继续key2以后的排序 ' br = szbr(ar, x, h): [k1].Resize(UBound(br) - LBound(br) + 1, UBound(br, 2) - LBound(br, 2) + 1) = br j2 = sr2(k): s = sr2(k + 1) '读取排序key的列序号j2 和Sort值s i = l: t = ar(x(i), j): i2 = i 'Do循环检查是否前key相同【注意，仅仅前key相同部分需要继续排序】 Do Do i2 = i2 + 1: If z(i2) Then Exit Do Else If ar(x(i2), j) <> t Then z(i2) = True: Exit Do '递增检查如果到了前前key的结束位置、或前key不同则停止退出Do循环 Loop If i2 - i > 1 Then '如果间隔>1 则本key需要排序处理【注意排序区间是小范围i,i2-1】 If s Mod 2 Then Call QuickSort1(ar, x, j2, i, i2 - 1) Else Call QuickSort2(ar, x, j2, i, i2 - 1) If s = 1 Then Call AZE(ar, x, j2, i, i2 - 1) '如果Sort值=1则需要调用AZE过程、把空值移动到最后 End If If i2 > u Then Exit Do Else i = i2: t = ar(x(i), j) '循环到最后时退出、否则继续从i2重新开始Do循环 Loop j = j2 '更新前key列位置j Next '全部排序循环结束后、为保证最后的排序稳定性、检查最后的key值相同时必须按Index值排序。 i = l: t = ar(x(i), j): i2 = i Do Do i2 = i2 + 1: If z(i2) Then Exit Do Else If ar(x(i2), j) <> t Then Exit Do '检查方法相同 Loop If i2 - i > 1 Then Call QuickSort(x, i, i2 - 1) '如果间隔>1 则Index值需要排序处理 If i2 > u Then Exit Do Else i = i2: t = ar(x(i), j) '循环到最后时退出、否则继续 Loop szpx = x '多key稳定排序处理结束、返回排序结果的Index数组x ' szpx = szbr(ar, x, h) '或返回按排序后Index顺序引用返回的排序结果数组br End Function Function QuickSort(x, l&, u&) 'A-Z QuickSort '最后稳定排序时对相同key的Index值升序排序 Dim i&, j&, n&, r& i = l: j = u: r = x((l + u) \ 2) While i < j While x(i) < r: i = i + 1: Wend 'A-Z While x(j) > r: j = j - 1: Wend 'A-Z If i <= j Then: n = x(i): x(i) = x(j): x(j) = n: i = i + 1: j = j - 1 Wend If l < j Then Call QuickSort(x, l, j) If i < u Then Call QuickSort(x, i, u) End Function Function QuickSort1(ar, x, j2&, l&, u&) 'A-Z QuickSort 按原数组j2列对应内容进行升序排序 Dim i&, j&, n&, r i = l: j = u: r = ar(x((l + u) \ 2), j2) While i < j While ar(x(i), j2) < r And i < u: i = i + 1: Wend 'A-Z While ar(x(j), j2) > r And j > l: j = j - 1: Wend 'A-Z If i <= j Then n = x(i): x(i) = x(j): x(j) = n: i = i + 1: j = j - 1 Wend If l < j Then Call QuickSort1(ar, x, j2, l, j) If i < u Then Call QuickSort1(ar, x, j2, i, u) End Function Function QuickSort2(ar, x, j2&, l&, u&) 'Z-A QuickSort 按原数组j2列对应内容进行降序排序 Dim i&, j&, n&, r i = l: j = u: r = ar(x((l + u) \ 2), j2) While i < j While ar(x(i), j2) > r And i < u: i = i + 1: Wend 'Z-A While ar(x(j), j2) < r And j > l: j = j - 1: Wend 'Z-A If i <= j Then n = x(i): x(i) = x(j): x(j) = n: i = i + 1: j = j - 1 Wend If l < j Then Call QuickSort2(ar, x, j2, l, j) If i < u Then Call QuickSort2(ar, x, j2, i, u) End Function Function AZE(ar, x, j, l&, u&) 'Sort值=1时、把排序完成后的空值移动到最后 Dim i&, i2&, y For i = l To u If ar(x(i), j) <> "" Then '检查直到非空位置时停止 y = x '复制Index数组x到y For i2 = l To i - 1 x(u - i + i2 + 1) = y(i2) '前面的空值对应Index值移动到最后 Next For i2 = i To u x(i2 - i + l) = y(i2) '后面的非空值对应Index值移动到前面 Next Exit For End If Next End Function Function szbr(ar, nr, h&) 'Output Result Array 按排序后nr数组顺序、引用原数组对应Index值各列返回数组排序结果 Dim br, i&, i2&, j2&, l&, l2&, u&, u2& l = LBound(ar) + h: u = UBound(ar) l2 = LBound(ar, 2): u2 = UBound(ar, 2) br = ar For i = l To u i2 = nr(i) '引用原数组对应Index值 For j2 = l2 To u2 br(i, j2) = ar(i2, j2) '按排序结果引用原数组对应值返回 Next Next szbr = br End Function
[本文转自仇朝权随笔_vba二维数组多key稳定排序](https://zawen.net/post/85.html)
♡♡♡转载请保留上面信息♡♡♡