Option Explicit

Private Sub test()
    Dim arr, brr
    arr = Range("A2:C25")
    brr = ArrSort2(arr, 2)    'arr对第2列作为关键字培训
    brr = ArrSort2(brr, 3)    '对brr第3列作为关键字培训
    Range("E2").Resize(UBound(arr), UBound(arr, 2)) = brr
End Sub

'下面是二维数组排序

Function ArrSort2(arr, key&)    '二维数组排序
    '二维数组 过程封转 返回排序后数组
    'arr=待排序二维数组 key=排序的列
    Dim i&, j&
    ReDim indexarr(LBound(arr) To UBound(arr)) As Long
    For i = LBound(arr) To UBound(arr)    '构造序号数组
        indexarr(i) = i
    Next
    ReDim brr(LBound(arr) To UBound(arr), LBound(arr, 2) To UBound(arr, 2))
    QuickSort2 arr, indexarr, key, LBound(arr), UBound(arr)
    '***Start**根据原始index顺序调整快速排序引起的不稳定排列
    '找出连续相等的序号起止 调用一维数组排序对序号数组排序 恢复index顺序
    i = LBound(arr)    '重排起点
    Dim istart&, iend&    '需要重排的序号数组下标 就是连续相同的局部
    istart = LBound(arr)

    For i = istart + 1 To UBound(arr)    '连续行判断 详细算法详见 连续行单元格合并
        'If arr(indexarr(istart), key) = 10 Then Stop
        If arr(indexarr(istart), key) = arr(indexarr(i), key) Then    '相等则连续编号 1
            j = j + 1
        Else
            iend = istart + j
            If j > 0 Then    '不相等且有连续相等的元素 对本段序号数组重排
                QuickSort indexarr, istart, iend
            End If
            j = 0
            istart = i    '分段起点下移一位
        End If
    Next

    If j > 0 Then    '最后一个区间处理 如果在循环内检测边界比较浪费 所以放在最后
        QuickSort indexarr, istart, UBound(arr)
    End If

    '***End***根据原始index顺序调整快速排序引起的不稳定排列

    '***Start***根据排好的行号输出结果二维数组
    For i = LBound(arr) To UBound(arr)
        For j = LBound(arr, 2) To UBound(arr, 2)
            brr(i, j) = arr(indexarr(i), j)
        Next
    Next
    ArrSort2 = brr
End Function

Private Function QuickSort2(ar, x() As Long, j2&, l&, u&)
    '升序二维数组快速排序  按原数组j2列对应内容进行升序排序
    '传入参数ar=源数据 x=上下标一致的一维数组 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 QuickSort2(ar, x, j2, l, j)
    If i < u Then Call QuickSort2(ar, x, j2, i, u)
End Function
'''下面是一维数组排序 郑广学 整理 2019.12.18

Function ArrSort(arr)
    '一维数组排序 过程封转 返回排序后数组
    Dim brr
    brr = arr
    QuickSort brr, LBound(brr), UBound(brr)
    ArrSort = brr
End Function

Sub QuickSort(tr, l&, u&)
    'tr为原始一维数组 L为排序起始下标 U为上标
    'EH论坛香川群子改进快速排序算法
    Dim i&, j&, x, t
    x = tr(l): i = l + 1: j = u
    Do
        Do While i < u
            If tr(i) > x Then Exit Do Else i = i + 1
        Loop
        Do While j > l
            If tr(j) < x Then Exit Do Else j = j - 1
        Loop
        If i < j Then t = tr(i): tr(i) = tr(j): tr(j) = t Else Exit Do
    Loop
    
    If j > l Then t = tr(l): tr(l) = tr(j): tr(j) = t: Call QuickSort(tr, l, j)
    If j + 1 < u Then Call QuickSort(tr, j + 1, u)
End Sub