VBA数组排序功能？

Posted 2023-03-27

技术标签:

【中文标题】VBA数组排序功能？【英文标题】：VBA array sort function? 【发布时间】：2010-09-14 05:13:55 【问题描述】：

我正在为 VBA 中的数组寻找一个不错的排序实现。首选快速排序。或者除了气泡或合并之外的任何其他sort algorithm 就足够了。

请注意，这适用于 MS Project 2003，因此应避免使用任何 Excel 原生函数和任何与 .net 相关的内容。

【问题讨论】：

看看这里可能会很有趣：rosettacode.org/wiki/Sorting_algorithms/Quicksort#VBA 你为什么不喜欢归并排序？ 【参考方案1】：

~~看看here：~~编辑： 引用的来源 (allexperts.com) 已经关闭，但这里是相关的 author cmets ：

网络上有许多用于排序的算法。最通用且通常最快的是Quicksort algorithm。下面是它的一个函数。

通过传递一个值数组（字符串或数字；没关系）调用它，数组下边界（通常是0）和数组上边界（即UBound(myArray).）

示例：Call QuickSort(myArray, 0, UBound(myArray))

完成后，myArray 将被排序，你可以用它做你想做的事。_{（来源：archive.org）}

Public Sub QuickSort(vArray As Variant, inLow As Long, inHi As Long)
  Dim pivot   As Variant
  Dim tmpSwap As Variant
  Dim tmpLow  As Long
  Dim tmpHi   As Long

  tmpLow = inLow
  tmpHi = inHi

  pivot = vArray((inLow + inHi) \ 2)

  While (tmpLow <= tmpHi)
     While (vArray(tmpLow) < pivot And tmpLow < inHi)
        tmpLow = tmpLow + 1
     Wend

     While (pivot < vArray(tmpHi) And tmpHi > inLow)
        tmpHi = tmpHi - 1
     Wend

     If (tmpLow <= tmpHi) Then
        tmpSwap = vArray(tmpLow)
        vArray(tmpLow) = vArray(tmpHi)
        vArray(tmpHi) = tmpSwap
        tmpLow = tmpLow + 1
        tmpHi = tmpHi - 1
     End If
  Wend

  If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
  If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi
End Sub

请注意，这只适用于单维（又名“正常”？）数组。（有一个有效的多维数组 QuickSort here。）

【讨论】：

这是处理重复项时稍快的实现。可能是由于\ 2。很好的答案:) 非常感谢！我在 2500 个条目的数据集上使用了插入排序，正确排序大约需要 22 秒。现在它在一秒钟内完成，这是一个奇迹！ ;) 这个函数的效果似乎总是将第一项从源中移动到目标中的最后一个位置，然后对数组的其余部分进行排序就好了。 @Egalth - 我已经用原始来源中的信息更新了问题 @ElieG。 - 我知道这条评论很旧，但对于其他有同样问题的人来说，vba 有两个用于划分整数的运算符。 / 将结果除并四舍五入到最接近的整数。 \ 进行整数除法并截断结果的小数部分【参考方案2】：

如果其他人想要的话，我将“快速快速排序”算法转换为 VBA。

我对其进行了优化，可在 Int/Longs 数组上运行，但将其转换为适用于任意可比较元素的数组应该很简单。

Private Sub QuickSort(ByRef a() As Long, ByVal l As Long, ByVal r As Long)
    Dim M As Long, i As Long, j As Long, v As Long
    M = 4

    If ((r - l) > M) Then
        i = (r + l) / 2
        If (a(l) > a(i)) Then swap a, l, i '// Tri-Median Methode!'
        If (a(l) > a(r)) Then swap a, l, r
        If (a(i) > a(r)) Then swap a, i, r

        j = r - 1
        swap a, i, j
        i = l
        v = a(j)
        Do
            Do: i = i + 1: Loop While (a(i) < v)
            Do: j = j - 1: Loop While (a(j) > v)
            If (j < i) Then Exit Do
            swap a, i, j
        Loop
        swap a, i, r - 1
        QuickSort a, l, j
        QuickSort a, i + 1, r
    End If
End Sub

Private Sub swap(ByRef a() As Long, ByVal i As Long, ByVal j As Long)
    Dim T As Long
    T = a(i)
    a(i) = a(j)
    a(j) = T
End Sub

Private Sub InsertionSort(ByRef a(), ByVal lo0 As Long, ByVal hi0 As Long)
    Dim i As Long, j As Long, v As Long

    For i = lo0 + 1 To hi0
        v = a(i)
        j = i
        Do While j > lo0
            If Not a(j - 1) > v Then Exit Do
            a(j) = a(j - 1)
            j = j - 1
        Loop
        a(j) = v
    Next i
End Sub

Public Sub sort(ByRef a() As Long)
    QuickSort a, LBound(a), UBound(a)
    InsertionSort a, LBound(a), UBound(a)
End Sub

【讨论】：

顺便说一下，这些是算法的 cmets：作者 James Gosling 和 Kevin A. Smith 扩展了 Denis Ahrens 的 TriMedian 和 InsertionSort，以及 Robert Sedgewick 的所有技巧，它使用 TriMedian 和 InsertionSort 进行列表小于 4。这是 CAR Hoare 的快速排序算法的通用版本。这将处理已经排序的数组，以及具有重复键的数组。感谢上帝我发布了这个。 3 小时后，我坠毁并失去了一天的工作，但至少能够恢复这一点。现在这就是 Karma 的作用。电脑很难。【参考方案3】：

Dim arr As Object
Dim InputArray

'Creating a array list
Set arr = CreateObject("System.Collections.ArrayList")

'String
InputArray = Array("d", "c", "b", "a", "f", "e", "g")

'number
'InputArray = Array(6, 5, 3, 4, 2, 1)

' adding the elements in the array to array_list
For Each element In InputArray
    arr.Add element
Next

'sorting happens
arr.Sort

'Converting ArrayList to an array
'so now a sorted array of elements is stored in the array sorted_array.

sorted_array = arr.toarray

【讨论】：

你能把它转换成一个函数并显示示例输出吗？关于速度的任何想法？ @Ans 拒绝了您的编辑 - 您删除了转换中的所有 cmets，因此只剩下未注释的代码（作为函数）。简短是好的，但在降低此答案的其他读者的“可理解性”时就不行了。 @Patrick Artner 代码非常简单，尤其是与此处发布的其他示例相比。我认为如果有人在这里寻找最简单的示例，如果只留下相关代码，他将能够更快地找到这个示例。会是一个很好的答案，但您可能必须处理System.Collections.ArrayList 在 32 位和 64 位 Windows 中位于不同位置的问题。我的 32 位 Excel 隐式尝试在 32 位 Win 存储它的位置找到它，但由于我有 64 位 Win，我也有一个问题：/ 我收到错误 -2146232576 (80131700)。谢谢普拉桑！其他蛮力方法的巧妙替代方案。【参考方案4】：

Explanation 是德语，但代码是经过充分测试的就地实现：

Private Sub QuickSort(ByRef Field() As String, ByVal LB As Long, ByVal UB As Long)
    Dim P1 As Long, P2 As Long, Ref As String, TEMP As String

    P1 = LB
    P2 = UB
    Ref = Field((P1 + P2) / 2)

    Do
        Do While (Field(P1) < Ref)
            P1 = P1 + 1
        Loop

        Do While (Field(P2) > Ref)
            P2 = P2 - 1
        Loop

        If P1 <= P2 Then
            TEMP = Field(P1)
            Field(P1) = Field(P2)
            Field(P2) = TEMP

            P1 = P1 + 1
            P2 = P2 - 1
        End If
    Loop Until (P1 > P2)

    If LB < P2 Then Call QuickSort(Field, LB, P2)
    If P1 < UB Then Call QuickSort(Field, P1, UB)
End Sub

这样调用：

Call QuickSort(MyArray, LBound(MyArray), UBound(MyArray))

【讨论】：

ByVal Field() 出现错误，必须使用默认的 ByRef。 @MarkNold - 我也是无论如何它都是 byref，因为 byval 不允许更改+保存字段值。如果您在传递的参数中绝对需要一个 byval，请使用变体而不是字符串，并且不要使用小括号 ()。 @Patrick 是的，我真的不知道ByVal 是如何进入那里的。混淆可能是因为在 VB.NET 中ByVal 可以在这里工作（尽管这在 VB.NET 中的实现方式有所不同）。【参考方案5】：

自然数（字符串）快速排序

只是为了讨论这个话题。通常，如果你用数字对字符串进行排序，你会得到这样的结果：

    Text1
    Text10
    Text100
    Text11
    Text2
    Text20

但你真的希望它能够识别数值并像

那样排序

    Text1
    Text2
    Text10
    Text11
    Text20
    Text100

这是怎么做的......

注意：

我很久以前从网上偷了快速排序，现在不知道在哪里...... 我也从网上翻译了最初用 C 语言编写的 CompareNaturalNum 函数。与其他 Q-Sort 的区别：如果 BottomTemp = TopTemp，我不会交换值

自然数快速排序

Public Sub QuickSortNaturalNum(strArray() As String, intBottom As Integer, intTop As Integer)
Dim strPivot As String, strTemp As String
Dim intBottomTemp As Integer, intTopTemp As Integer

    intBottomTemp = intBottom
    intTopTemp = intTop

    strPivot = strArray((intBottom + intTop) \ 2)

    Do While (intBottomTemp <= intTopTemp)
        ' < comparison of the values is a descending sort
        Do While (CompareNaturalNum(strArray(intBottomTemp), strPivot) < 0 And intBottomTemp < intTop)
            intBottomTemp = intBottomTemp + 1
        Loop
        Do While (CompareNaturalNum(strPivot, strArray(intTopTemp)) < 0 And intTopTemp > intBottom) '
            intTopTemp = intTopTemp - 1
        Loop
        If intBottomTemp < intTopTemp Then
            strTemp = strArray(intBottomTemp)
            strArray(intBottomTemp) = strArray(intTopTemp)
            strArray(intTopTemp) = strTemp
        End If
        If intBottomTemp <= intTopTemp Then
            intBottomTemp = intBottomTemp + 1
            intTopTemp = intTopTemp - 1
        End If
    Loop

    'the function calls itself until everything is in good order
    If (intBottom < intTopTemp) Then QuickSortNaturalNum strArray, intBottom, intTopTemp
    If (intBottomTemp < intTop) Then QuickSortNaturalNum strArray, intBottomTemp, intTop
End Sub

自然数比较（用于快速排序）

Function CompareNaturalNum(string1 As Variant, string2 As Variant) As Integer
'string1 is less than string2 -1
'string1 is equal to string2 0
'string1 is greater than string2 1
Dim n1 As Long, n2 As Long
Dim iPosOrig1 As Integer, iPosOrig2 As Integer
Dim iPos1 As Integer, iPos2 As Integer
Dim nOffset1 As Integer, nOffset2 As Integer

    If Not (IsNull(string1) Or IsNull(string2)) Then
        iPos1 = 1
        iPos2 = 1
        Do While iPos1 <= Len(string1)
            If iPos2 > Len(string2) Then
                CompareNaturalNum = 1
                Exit Function
            End If
            If isDigit(string1, iPos1) Then
                If Not isDigit(string2, iPos2) Then
                    CompareNaturalNum = -1
                    Exit Function
                End If
                iPosOrig1 = iPos1
                iPosOrig2 = iPos2
                Do While isDigit(string1, iPos1)
                    iPos1 = iPos1 + 1
                Loop

                Do While isDigit(string2, iPos2)
                    iPos2 = iPos2 + 1
                Loop

                nOffset1 = (iPos1 - iPosOrig1)
                nOffset2 = (iPos2 - iPosOrig2)

                n1 = Val(Mid(string1, iPosOrig1, nOffset1))
                n2 = Val(Mid(string2, iPosOrig2, nOffset2))

                If (n1 < n2) Then
                    CompareNaturalNum = -1
                    Exit Function
                ElseIf (n1 > n2) Then
                    CompareNaturalNum = 1
                    Exit Function
                End If

                ' front padded zeros (put 01 before 1)
                If (n1 = n2) Then
                    If (nOffset1 > nOffset2) Then
                        CompareNaturalNum = -1
                        Exit Function
                    ElseIf (nOffset1 < nOffset2) Then
                        CompareNaturalNum = 1
                        Exit Function
                    End If
                End If
            ElseIf isDigit(string2, iPos2) Then
                CompareNaturalNum = 1
                Exit Function
            Else
                If (Mid(string1, iPos1, 1) < Mid(string2, iPos2, 1)) Then
                    CompareNaturalNum = -1
                    Exit Function
                ElseIf (Mid(string1, iPos1, 1) > Mid(string2, iPos2, 1)) Then
                    CompareNaturalNum = 1
                    Exit Function
                End If

                iPos1 = iPos1 + 1
                iPos2 = iPos2 + 1
            End If
        Loop
        ' Everything was the same so far, check if Len(string2) > Len(String1)
        ' If so, then string1 < string2
        If Len(string2) > Len(string1) Then
            CompareNaturalNum = -1
            Exit Function
        End If
    Else
        If IsNull(string1) And Not IsNull(string2) Then
            CompareNaturalNum = -1
            Exit Function
        ElseIf IsNull(string1) And IsNull(string2) Then
            CompareNaturalNum = 0
            Exit Function
        ElseIf Not IsNull(string1) And IsNull(string2) Then
            CompareNaturalNum = 1
            Exit Function
        End If
    End If
End Function

isDigit（用于 CompareNaturalNum）

Function isDigit(ByVal str As String, pos As Integer) As Boolean
Dim iCode As Integer
    If pos <= Len(str) Then
        iCode = Asc(Mid(str, pos, 1))
        If iCode >= 48 And iCode <= 57 Then isDigit = True
    End If
End Function

【讨论】：

很好 - 我喜欢 NaturalNumber 排序 - 必须将其添加为选项【参考方案6】：

我发布了一些代码来回答 *** 上的相关问题：

Sorting a multidimensionnal array in VBA

该线程中的代码示例包括：

向量数组快速排序；多列数组快速排序；冒泡排序。

Alain 优化的快速排序非常出色：我刚刚做了一个基本的拆分和递归，但上面的代码示例有一个“门控”功能，可以减少重复值的冗余比较。另一方面，我为 Excel 编写代码，并且在防御性编码方面还有更多 - 请注意，如果您的数组包含有害的 'Empty()' 变体，您将需要它，这会破坏您的 While .. . 使用比较运算符并将您的代码陷入无限循环。

请注意，快速排序算法（以及任何递归算法）可能会填满堆栈并导致 Excel 崩溃。如果您的数组的成员少于 1024 个，我会使用基本的 BubbleSort。

Public Sub QuickSortArray(ByRef SortArray As Variant, _ 可选 lngMin As Long = -1, _ 可选 lngMax As Long = -1, _ 可选 lngColumn As Long = 0) 出错时继续下一步 '对二维数组进行排序 ' 示例用法：按第 3 列的内容对 arrData 进行排序 ' ' QuickSortArray arrData, , , 3 ' '由 Jim Rech 发表于 10/20/98 Excel.Programming '修改，奈杰尔赫弗南： ' ' 转义失败与空变体的比较 ' ' 防御性编码：检查输入暗淡我只要暗淡 j 只要将 varMid 调暗为变体将 arrRowTemp 调暗为变体将 lngColTemp 调暗 If IsEmpty(SortArray) 那么退出子结束如果 If InStr(TypeName(SortArray), "()") 如果 lngMin = -1 那么 lngMin = LBound(SortArray, 1) 结束如果如果 lngMax = -1 那么 lngMax = UBound(SortArray, 1) 结束如果 If lngMin >= lngMax Then ' 不需要排序退出子结束如果 i = lngMin j = lngMax varMid = 空 varMid = SortArray((lngMin + lngMax) \ 2, lngColumn) ' 我们将“空”和无效数据项发送到列表末尾： If IsObject(varMid) Then ' 请注意，我们不检查 isObject(SortArray(n)) - varMid 可能选择一个有效的默认成员或属性 i = lngMax j = lngMin ElseIf IsEmpty(varMid) Then i = lngMax j = lngMin ElseIf IsNull(varMid) Then i = lngMax j = lngMin ElseIf varMid = "" 那么 i = lngMax j = lngMin ElseIf varType(varMid) = vbError Then i = lngMax j = lngMin ElseIf varType(varMid) > 17 那么 i = lngMax j = lngMin 结束如果虽然我虽然 SortArray(i, lngColumn) 而 varMid lngMin j = j - 1 温德如果 i ' 交换行 ReDim arrRowTemp(LBound(SortArray, 2) 到 UBound(SortArray, 2)) 对于 lngColTemp = LBound(SortArray, 2) 到 UBound(SortArray, 2) arrRowTemp(lngColTemp) = SortArray(i, lngColTemp) SortArray(i, lngColTemp) = SortArray(j, lngColTemp) SortArray(j, lngColTemp) = arrRowTemp(lngColTemp) 下一个 lngColTemp 擦除 arrRowTemp 我 = 我 + 1 j = j - 1 结束如果温德 If (lngMin 结束子

【讨论】：

【参考方案7】：

我想知道你对这个数组排序代码有什么看法。它的实施速度很快，并且可以完成工作……尚未针对大型阵列进行测试。它适用于一维数组，对于多维附加值，需要构建重定位矩阵（比初始数组少一维）。

       For AR1 = LBound(eArray, 1) To UBound(eArray, 1)
            eValue = eArray(AR1)
            For AR2 = LBound(eArray, 1) To UBound(eArray, 1)
                If eArray(AR2) < eValue Then
                    eArray(AR1) = eArray(AR2)
                    eArray(AR2) = eValue
                    eValue = eArray(AR1)
                End If
            Next AR2
        Next AR1

【讨论】：

这是冒泡排序。 OP 要求的不是气泡。【参考方案8】：

您不想要基于 Excel 的解决方案，但由于我今天遇到了同样的问题并想使用其他 Office 应用程序功能进行测试，所以我编写了以下函数。

限制：

二维数组；最多 3 列作为排序键；取决于 Excel；

测试从 Visio 2010 调用 Excel 2010

Option Base 1


Private Function sort_array_2D_excel(array_2D, array_sortkeys, Optional array_sortorders, Optional tag_header As String = "Guess", Optional tag_matchcase As String = "False")

'   Dependencies: Excel; Tools > References > Microsoft Excel [Version] Object Library

    Dim excel_application As Excel.Application
    Dim excel_workbook As Excel.Workbook
    Dim excel_worksheet As Excel.Worksheet

    Set excel_application = CreateObject("Excel.Application")

    excel_application.Visible = True
    excel_application.ScreenUpdating = False
    excel_application.WindowState = xlNormal

    Set excel_workbook = excel_application.Workbooks.Add
    excel_workbook.Activate

    Set excel_worksheet = excel_workbook.Worksheets.Add
    excel_worksheet.Activate
    excel_worksheet.Visible = xlSheetVisible

    Dim excel_range As Excel.Range
    Set excel_range = excel_worksheet.Range("A1").Resize(UBound(array_2D, 1) - LBound(array_2D, 1) + 1, UBound(array_2D, 2) - LBound(array_2D, 2) + 1)
    excel_range = array_2D


    For i_sortkey = LBound(array_sortkeys) To UBound(array_sortkeys)

        If IsNumeric(array_sortkeys(i_sortkey)) Then
            sortkey_range = Chr(array_sortkeys(i_sortkey) + 65 - 1) & "1"
            Set array_sortkeys(i_sortkey) = excel_worksheet.Range(sortkey_range)

        Else
            MsgBox "Error in sortkey parameter:" & vbLf & "array_sortkeys(" & i_sortkey & ") = " & array_sortkeys(i_sortkey) & vbLf & "Terminating..."
            End

        End If

    Next i_sortkey


    For i_sortorder = LBound(array_sortorders) To UBound(array_sortorders)
        Select Case LCase(array_sortorders(i_sortorder))
            Case "asc"
                array_sortorders(i_sortorder) = XlSortOrder.xlAscending
            Case "desc"
                array_sortorders(i_sortorder) = XlSortOrder.xlDescending
            Case Else
                array_sortorders(i_sortorder) = XlSortOrder.xlAscending
        End Select
    Next i_sortorder

    Select Case LCase(tag_header)
        Case "yes"
            tag_header = Excel.xlYes
        Case "no"
            tag_header = Excel.xlNo
        Case "guess"
            tag_header = Excel.xlGuess
        Case Else
            tag_header = Excel.xlGuess
    End Select

    Select Case LCase(tag_matchcase)
        Case "true"
            tag_matchcase = True
        Case "false"
            tag_matchcase = False
        Case Else
            tag_matchcase = False
    End Select


    Select Case (UBound(array_sortkeys) - LBound(array_sortkeys) + 1)
        Case 1
            Call excel_range.Sort(Key1:=array_sortkeys(1), Order1:=array_sortorders(1), Header:=tag_header, MatchCase:=tag_matchcase)
        Case 2
            Call excel_range.Sort(Key1:=array_sortkeys(1), Order1:=array_sortorders(1), Key2:=array_sortkeys(2), Order2:=array_sortorders(2), Header:=tag_header, MatchCase:=tag_matchcase)
        Case 3
            Call excel_range.Sort(Key1:=array_sortkeys(1), Order1:=array_sortorders(1), Key2:=array_sortkeys(2), Order2:=array_sortorders(2), Key3:=array_sortkeys(3), Order3:=array_sortorders(3), Header:=tag_header, MatchCase:=tag_matchcase)
        Case Else
            MsgBox "Error in sortkey parameter:" & vbLf & "Maximum number of sort columns is 3!" & vbLf & "Currently passed: " & (UBound(array_sortkeys) - LBound(array_sortkeys) + 1)
            End
    End Select


    For i_row = 1 To excel_range.Rows.Count

        For i_column = 1 To excel_range.Columns.Count

            array_2D(i_row, i_column) = excel_range(i_row, i_column)

        Next i_column

    Next i_row


    excel_workbook.Close False
    excel_application.Quit

    Set excel_worksheet = Nothing
    Set excel_workbook = Nothing
    Set excel_application = Nothing


    sort_array_2D_excel = array_2D


End Function

这是一个关于如何测试函数的示例：

Private Sub test_sort()

    array_unsorted = dim_sort_array()

    Call msgbox_array(array_unsorted)

    array_sorted = sort_array_2D_excel(array_unsorted, Array(2, 1, 3), Array("desc", "", "asdas"), "yes", "False")

    Call msgbox_array(array_sorted)

End Sub


Private Function dim_sort_array()

    Dim array_unsorted(1 To 5, 1 To 3) As String

    i_row = 0

    i_row = i_row + 1
    array_unsorted(i_row, 1) = "Column1": array_unsorted(i_row, 2) = "Column2": array_unsorted(i_row, 3) = "Column3"

    i_row = i_row + 1
    array_unsorted(i_row, 1) = "OR": array_unsorted(i_row, 2) = "A": array_unsorted(i_row, 3) = array_unsorted(i_row, 1) & "_" & array_unsorted(i_row, 2)

    i_row = i_row + 1
    array_unsorted(i_row, 1) = "XOR": array_unsorted(i_row, 2) = "A": array_unsorted(i_row, 3) = array_unsorted(i_row, 1) & "_" & array_unsorted(i_row, 2)

    i_row = i_row + 1
    array_unsorted(i_row, 1) = "NOT": array_unsorted(i_row, 2) = "B": array_unsorted(i_row, 3) = array_unsorted(i_row, 1) & "_" & array_unsorted(i_row, 2)

    i_row = i_row + 1
    array_unsorted(i_row, 1) = "AND": array_unsorted(i_row, 2) = "A": array_unsorted(i_row, 3) = array_unsorted(i_row, 1) & "_" & array_unsorted(i_row, 2)

    dim_sort_array = array_unsorted

End Function


Sub msgbox_array(array_2D, Optional string_info As String = "2D array content:")

    msgbox_string = string_info & vbLf

    For i_row = LBound(array_2D, 1) To UBound(array_2D, 1)

        msgbox_string = msgbox_string & vbLf & i_row & vbTab

        For i_column = LBound(array_2D, 2) To UBound(array_2D, 2)

            msgbox_string = msgbox_string & array_2D(i_row, i_column) & vbTab

        Next i_column

    Next i_row

    MsgBox msgbox_string

End Sub

如果有人使用其他版本的 office 对此进行测试，如果有任何问题，请在此处发布。

【讨论】：

我忘了提到msgbox_array() 是一个在调试时快速检查任何二维数组的函数。【参考方案9】：

@Prasand Kumar，这是一个基于 Prasand 概念的完整排序例程：

Public Sub ArrayListSort(ByRef SortArray As Variant)
    '
    'Uses the sort capabilities of a System.Collections.ArrayList object to sort an array of values of any simple
    'data-type.
    '
    'AUTHOR: Peter Straton
    '
    'CREDIT: Derived from Prasand Kumar's post at: https://***.com/questions/152319/vba-array-sort-function
    '
    '*************************************************************************************************************

    Static ArrayListObj As Object
    Dim i As Long
    Dim LBnd As Long
    Dim UBnd As Long

    LBnd = LBound(SortArray)
    UBnd = UBound(SortArray)

    'If necessary, create the ArrayList object, to be used to sort the specified array's values

    If ArrayListObj Is Nothing Then
        Set ArrayListObj = CreateObject("System.Collections.ArrayList")
    Else
        ArrayListObj.Clear  'Already allocated so just clear any old contents
    End If

    'Add the ArrayList elements from the array of values to be sorted. (There appears to be no way to do this
    'using a single assignment statement.)

    For i = LBnd To UBnd
        ArrayListObj.Add SortArray(i)
    Next i

    ArrayListObj.Sort   'Do the sort

    'Transfer the sorted ArrayList values back to the original array, which can be done with a single assignment
    'statement.  But the result is always zero-based so then, if necessary, adjust the resulting array to match
    'its original index base.

    SortArray = ArrayListObj.ToArray
    If LBnd <> 0 Then ReDim Preserve SortArray(LBnd To UBnd)
End Sub

【讨论】：

【参考方案10】：

我认为我的代码（经过测试）更“受过教育”，假设 越简单越好。

Option Base 1

'Function to sort an array decscending
Function SORT(Rango As Range) As Variant
    Dim check As Boolean
    check = True
    If IsNull(Rango) Then
        check = False
    End If
    If check Then
        Application.Volatile
        Dim x() As Variant, n As Double, m As Double, i As Double, j As Double, k As Double
        n = Rango.Rows.Count: m = Rango.Columns.Count: k = n * m
        ReDim x(n, m)
        For i = 1 To n Step 1
            For j = 1 To m Step 1
                x(i, j) = Application.Large(Rango, k)
                k = k - 1
            Next j
        Next i
        SORT = x
    Else
        Exit Function
    End If
End Function

【讨论】：

这是什么类型的？为什么说它“受过教育”？从阅读代码来看，它似乎将整个二维数组（取自 Excel 工作表）“排序”在整个数组（而不是某个特定维度）上。所以值会改变它们的维度索引。然后将结果放回工作表。虽然代码可能适用于简单的情况，但此代码存在很多问题。我注意到的第一件事是到处使用Double 而不是Long。其次，它没有考虑范围是否有多个区域。对矩形进行排序似乎没有用，当然这不是 OP 要求的（特别是说没有原生 Excel/.Net 解决方案）。另外，如果您将越简单越好等同于“受过教育”，那么使用内置的Range.Sort()函数不是最好的吗？【参考方案11】：

这是我用来在内存中排序的——它可以很容易地扩展为对数组进行排序。

Sub sortlist()

    Dim xarr As Variant
    Dim yarr As Variant
    Dim zarr As Variant

    xarr = Sheets("sheet").Range("sing col range")
    ReDim yarr(1 To UBound(xarr), 1 To 1)
    ReDim zarr(1 To UBound(xarr), 1 To 1)

    For n = 1 To UBound(xarr)
        zarr(n, 1) = 1
    Next n

    For n = 1 To UBound(xarr) - 1
        y = zarr(n, 1)
        For a = n + 1 To UBound(xarr)
            If xarr(n, 1) > xarr(a, 1) Then
                y = y + 1
            Else
                zarr(a, 1) = zarr(a, 1) + 1
            End If
        Next a
        yarr(y, 1) = xarr(n, 1)
    Next n

    y = zarr(UBound(xarr), 1)
    yarr(y, 1) = xarr(UBound(xarr), 1)

    yrng = "A1:A" & UBound(yarr)
    Sheets("sheet").Range(yrng) = yarr

End Sub

【讨论】：

【参考方案12】：

Heapsort 实现。一个 O(n log(n))（平均和最坏情况），就地，unstable 排序算法。

与：Call HeapSort(A) 一起使用，其中A 是变体的一维数组，与Option Base 1 一起使用。

Sub SiftUp(A() As Variant, I As Long)
    Dim K As Long, P As Long, S As Variant
    K = I
    While K > 1
        P = K \ 2
        If A(K) > A(P) Then
            S = A(P): A(P) = A(K): A(K) = S
            K = P
        Else
            Exit Sub
        End If
    Wend
End Sub

Sub SiftDown(A() As Variant, I As Long)
    Dim K As Long, L As Long, S As Variant
    K = 1
    Do
        L = K + K
        If L > I Then Exit Sub
        If L + 1 <= I Then
            If A(L + 1) > A(L) Then L = L + 1
        End If
        If A(K) < A(L) Then
            S = A(K): A(K) = A(L): A(L) = S
            K = L
        Else
            Exit Sub
        End If
    Loop
End Sub

Sub HeapSort(A() As Variant)
    Dim N As Long, I As Long, S As Variant
    N = UBound(A)
    For I = 2 To N
        Call SiftUp(A, I)
    Next I
    For I = N To 2 Step -1
        S = A(I): A(I) = A(1): A(1) = S
        Call SiftDown(A, I - 1)
    Next
End Sub

【讨论】：

【参考方案13】：

有点相关，但我也在寻找原生 excel VBA 解决方案，因为高级数据结构（字典等）在我的环境中不起作用。下面通过VBA中的二叉树实现排序：

假设数组是一一填充的 删除重复项 返回一个可拆分的分隔字符串 ("0|2|3|4|9")。

我用它来返回为任意选择的范围选择的行的原始排序枚举

Private Enum LeafType: tEMPTY: tTree: tValue: End Enum
Private Left As Variant, Right As Variant, Center As Variant
Private LeftType As LeafType, RightType As LeafType, CenterType As LeafType
Public Sub Add(x As Variant)
    If CenterType = tEMPTY Then
        Center = x
        CenterType = tValue
    ElseIf x > Center Then
        If RightType = tEMPTY Then
            Right = x
            RightType = tValue
        ElseIf RightType = tTree Then
            Right.Add x
        ElseIf x <> Right Then
            curLeaf = Right
            Set Right = New TreeList
            Right.Add curLeaf
            Right.Add x
            RightType = tTree
        End If
    ElseIf x < Center Then
        If LeftType = tEMPTY Then
            Left = x
            LeftType = tValue
        ElseIf LeftType = tTree Then
            Left.Add x
        ElseIf x <> Left Then
            curLeaf = Left
            Set Left = New TreeList
            Left.Add curLeaf
            Left.Add x
            LeftType = tTree
        End If
    End If
End Sub
Public Function GetList$()
    Const sep$ = "|"
    If LeftType = tValue Then
        LeftList$ = Left & sep
    ElseIf LeftType = tTree Then
        LeftList = Left.GetList & sep
    End If
    If RightType = tValue Then
        RightList$ = sep & Right
    ElseIf RightType = tTree Then
        RightList = sep & Right.GetList
    End If
    GetList = LeftList & Center & RightList
End Function

'Sample code
Dim Tree As new TreeList
Tree.Add("0")
Tree.Add("2")
Tree.Add("2")
Tree.Add("-1")
Debug.Print Tree.GetList() 'prints "-1|0|2"
sortedList = Split(Tree.GetList(),"|")

【讨论】：

以上是关于VBA数组排序功能？的主要内容，如果未能解决你的问题，请参考以下文章

用于自动筛选排序 SortFields 的 VBA 不使用其他列排序进行排序

[iOS功能]- iOS数组排序(倒叙生序降序)

vba怎么样防止数组的数据超过15位时丢失

怎么取数组的中间值

vba代码求助，将修改区域复制到数组中？

Java中怎么取出数组中某个单位的某个值进行排序?