logo标签列表

VBA数组排序函数？

arrayssortingvbavb6ms-project
103

我在寻找一个适用于VBA数组的良好排序实现。最好是快排，或者除了冒泡排序和归并排序之外的任何其他排序算法都可以。

请注意，这是要与MS Project 2003一起使用的，因此应避免使用任何Excel本机函数和任何与.net相关的内容。

3
这里可能会很有趣，你可以看一下这个链接：http://rosettacode.org/wiki/Sorting_algorithms/Quicksort#VBA。 - Femi
你为什么不喜欢归并排序？ - jwg
14个回答
129

在这里看一下:
编辑：引用的来源（allexperts.com）已经关闭，但以下是相关的作者的评论：

网上有许多可用于排序的算法。 最通用和通常最快的是 快速排序算法。 下面是一个用于它的函数。

只需通过传递值数组（字符串或数字；没有关系）、较低的数组边界（通常为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

请注意，这仅适用于单维度（也称为“普通”？）数组。（这里有一个可以处理多维数组的快速排序链接。）

3
处理重复数据时，这是略微更快的实现方式。可能是由于 \ 2 导致的。好的答案 :) - Mark Nold
2
@Egalth - 我已经更新了问题，并添加了原始来源上的信息。 - ashleedawg
1
@ChrisB 括号不是必需的，但使用它们可以使代码更易读。 - Elie G.
2
@ElieG. - 我知道这个评论已经有点老了，但是对于其他有同样问题的人来说，vba有两个整数除法运算符。/ 进行除法并将结果四舍五入到最近的整数。\ 进行整数除法并截断结果的小数部分。 - Jason Wisnieski
1
为了正确地使用它进行区分大小写的字符串比较，我在模块开头使用 Option Compare Text，否则它将使用二进制比较。 - Dounchan
显示剩余7条评论
25
我将“快速排序”算法转换为VBA，如果有其他人需要，可以使用。
我已经对其进行了优化，可以在Int / Long数组上运行，但是将其转换为适用于任意可比较元素的算法应该很简单。
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
这是算法的评论： 作者James Gosling和Kevin A. Smith，由Denis Ahrens扩展了TriMedian和InsertionSort，并得到了Robert Sedgewick的所有提示。对于长度小于4的列表，它使用TriMedian和InsertionSort。这是C.A.R Hoare快速排序算法的通用版本。它可以处理已经排序过的数组和具有重复键的数组。 - Alain
22
感谢上天我发布了这个。三小时后，我电脑崩溃了，丢失了一整天的工作，但我至少能够恢复这个。这就是因果报应。计算机太难了。 - Alain
1
这是否意味着不使用您的函数，以避免崩溃电脑？ - Waleed
@Waleed 不是的 :) 崩溃与上述算法无关。 - Alain
15
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
你能将这个转换成一个函数并展示输出示例吗？对于速度有什么想法吗？ - not2qubit
2
@Ans 拒绝了您的编辑 - 您删除了所有有关转换的注释，只留下未注释的代码（作为函数）。简洁是美好的，但不应该牺牲其他读者理解答案的能力。 - Patrick Artner
1
这是一个很好的答案，但你可能需要处理一个问题，即System.Collections.ArrayList在32位和64位Windows中的位置不同。我的32位Excel隐式地尝试在32位Win存储它的位置找到它，但由于我有64位Win，所以我也遇到了问题：/我收到了一个错误-2146232576（80131700）。 - ZygD
谢谢Prasand！这是另一种聪明的替代方案，与其他暴力方法不同。 - pstraton
1
@ZygD 原因很可能是缺少安装 .NET Framework v3.5。我已经在帖子中添加了一条注释（等待编辑审核）。 - mh166
显示剩余2条评论
13

该网站提供了德语的解释，但代码是一个经过充分测试的原地实现：

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))
1
我在使用 ByVal Field() 时遇到了错误，不得不使用默认的 ByRef。 - Mark Nold
@MarkNold - 我也是。 - Richard H
无论如何，它都是按引用传递的，因为按值传递不允许更改和保存字段值。如果您绝对需要在传递的参数中使用按值传递，请改用变量而不是字符串，并且不要使用括号（）。 - Patrick Lepelletier
@Patrick 嗯，我不太清楚ByVal是怎么进去的。这可能是由于在VB.NET中 ByVal 会起作用（尽管在VB.NET中实现方式会有所不同）导致混淆。 - Konrad Rudolph
10

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

仅作为话题的补充。通常，如果使用数字对字符串进行排序，您会得到类似于以下内容：

    Text1
    Text10
    Text100
    Text11
    Text2
    Text20

但是您确实希望它能够识别数字值并按如下排序

    Text1
    Text2
    Text10
    Text11
    Text20
    Text100

以下是如何执行操作的...

注：

  • 我很久以前从互联网上偷了快速排序算法，现在不确定来源在哪里...
  • 我也翻译了最初是用C语言编写的CompareNaturalNum函数。
  • 与其他快速排序算法的区别：如果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
很好 - 我喜欢自然数排序 - 需要将其作为一个选项添加 - Mark Nold
我的数组（"test2"，"test1"，"test10"，"test3"）将被排序为"test1"，"test2"，"test10"，"test3"，为什么会这样？显然有9个用户投票认为这是一个有效的解决方案，但对我来说顺序没有意义。请问有人可以给予建议吗？ - smartini
@smartini，只有在边界设置不正确的情况下，我才会得到那个结果。具体来说，顶部缺少最后一个元素（[array,0,3]而不是[array,0,2]）。 - Profex
7

我在StackOverflow上回答了一个相关问题，并发布了一些代码:

在VBA中对多维数组进行排序

该主题中的代码示例包括:

  1. 向量数组快速排序;
  2. 多列数组QuickSort;
  3. BubbleSort。

Alain的优化快速排序非常出色: 我只是做了一个基本的分割和递归，但是上面的代码示例具有一个'gating'函数，可以减少重复值的冗余比较。另一方面，我为Excel编写代码，需要更多的防御性编码 - 警告：如果您的数组包含有害的“Empty()”变体，将破坏您的While... Wend比较运算符并使您的代码陷入无限循环。

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

Public Sub QuickSortArray(ByRef SortArray As Variant, _ Optional lngMin As Long = -1, _ Optional lngMax As Long = -1, _ Optional lngColumn As Long = 0) On Error Resume Next
'对一个二维数组进行排序
'使用示例：按第三列的内容对arrData进行排序 ' ' QuickSortArray arrData, , , 3
' 'Jim Rech发布于10/20/98 Excel.Programming
'修改，Nigel Heffernan：
' ' 用空变量避免比较失败 ' ' 防御性编程：检查输入
Dim i As Long Dim j As Long Dim varMid As Variant Dim arrRowTemp As Variant Dim lngColTemp As Long

If IsEmpty(SortArray) Then 退出子程序 End If
If InStr(TypeName(SortArray), "()") < 1 Then 'IsArray()有些问题：在类型名称中寻找括号 退出子程序 End If
If lngMin = -1 Then lngMin = LBound(SortArray, 1) End If
If lngMax = -1 Then lngMax = UBound(SortArray, 1) End If
If lngMin >= lngMax Then ' 不需要排序 退出子程序 End If

i = lngMin j = lngMax
varMid = Empty 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 = "" Then i = lngMax j = lngMin ElseIf varType(varMid) = vbError Then i = lngMax j = lngMin ElseIf varType(varMid) > 17 Then i = lngMax j = lngMin End If

While i <= j
While SortArray(i, lngColumn) < varMid And i < lngMax i = i + 1 Wend
While varMid < SortArray(j, lngColumn) And j > lngMin j = j - 1 Wend

If i <= j Then
' 交换行 ReDim arrRowTemp(LBound(SortArray, 2) To UBound(SortArray, 2)) For lngColTemp = LBound(SortArray, 2) To UBound(SortArray, 2) arrRowTemp(lngColTemp) = SortArray(i, lngColTemp) SortArray(i, lngColTemp) = SortArray(j, lngColTemp) SortArray(j, lngColTemp) = arrRowTemp(lngColTemp) Next lngColTemp Erase arrRowTemp
i = i + 1 j = j - 1
End If

Wend
If (lngMin < j) Then Call QuickSortArray(SortArray, lngMin, j, lngColumn) If (i < lngMax) Then Call QuickSortArray(SortArray, i, lngMax, lngColumn)

End Sub
2

您不希望使用基于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进行测试，请在此处发布是否存在任何问题。

1
我忘了提到msgbox_array()是一个在调试时快速检查任何二维数组的有用函数。 - lucas0x7B
2

我想知道你对这段数组排序代码有什么看法。它的实现很快，可以胜任任务......但还没有测试过大型数组。它适用于一维数组，对于多维数组，需要构建一个重新定位矩阵（比初始数组少一维）。

       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
5
这是冒泡排序。原帖要求除冒泡排序以外的其他内容。 - Michiel van der Blonk
1

@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://dev59.com/03VC5IYBdhLWcg3w51dv
    '
    '*************************************************************************************************************

    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
1

有点相关，但我也在寻找本地的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(),"|")
网页内容由stack overflow 提供, 点击上面的
可以查看英文原文，
原文链接