我正在寻找一种在VBA中对数组进行体面排序的实现。最好使用Quicksort。否则,除了冒泡或合并以外的任何其他排序算法都足够。

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

评论

在这里看看可能会很有趣:rosettacode.org/wiki/Sorting_algorithms/Quicksort#VBA

为什么不喜欢合并排序?

#1 楼

在这里看一下:编辑:引用的源(allexperts.com)已关闭,但是这里是相关的作者注释:


网络上有很多算法可用于排序。功能最丰富,通常最快的是Quicksort算法。下面是它的功能。

只需通过传递带有下数组边界(通常为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。)

评论


处理重复项时,这是稍微快一点的实现。可能是由于\ 2.好答案:)

– Mark Nold
08年10月1日在2:50

为此非常感谢!我在2500个条目数据集上使用插入排序,大约需要22秒才能正确排序。现在它在一秒钟内完成,这是一个奇迹! ;)

– djule5
2011-10-14 13:23

此功能的作用似乎总是将源中的第一项移动到目标中的最后位置,并对数组的其余部分进行排序。

–茉莉
2015年10月8日19:30

9年后仍是一个不错的解决方案。但不幸的是,所引用的页面allexperts.com不再存在...

– Egalth
18年1月18日在20:20

@Egalth-我已经用原始来源上的信息更新了问题

–ashleedawg
18年5月10日在1:34

#2 楼

如果有人需要,我将“快速快速排序”算法转换为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的所有技巧,它将TriMedian和InsertionSort用于少于4的列表。这是一个CAR Hoare的快速排序算法的通用版本。这将处理已排序的数组和具有重复键的数组。

–阿兰
2010-12-03 16:16



谢谢上帝,我张贴了这个。 3小时后,我坠机了,失去了一天的工作,但至少能够恢复原状。现在,这就是业力。电脑很难。

–阿兰
2010-12-03 19:59

#3 楼

用德语解释,但是代码是经过良好测试的就地实现:

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。

– Mark Nold
08年10月1日在2:47

@MarkNold-我也是

–Richard H
2015年9月1日在9:30

无论如何,它都是byref,因为byval不允许更改+保存Field值。如果您绝对需要在传递的参数中使用byval,请使用变体而不是字符串,并且不要使用brickt()。

– Patrick Lepelletier
16年1月21日在12:34

@Patrick是的,我真的不知道ByVal是如何进入那里的。造成这种混乱的原因可能是,在VB.NET中ByVal可以在这里工作(尽管无论如何在VB.NET中都可以实现)。

–康拉德·鲁道夫(Konrad Rudolph)
16年1月21日,12:43

#4 楼

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
17-10-29在10:21

@Ans拒绝了您的修改-您删除了转换中的所有注释,因此仅留下了未注释的代码(作为函数)。简短是很好的选择,但是对于其他一些对此感到不满意的读者而言,则不是那么容易。

–帕特里克·阿特纳(Patrick Artner)
18年1月18日在9:52

@Patrick Artner的代码非常简单,尤其是与此处发布的其他示例相比。我认为,如果有人在这里寻找最简单的示例,那么仅保留相关代码,他就能更快地找到该示例。

– Ans
18年1月18日在10:19

这将是一个很好的答案,但您可能必须处理System.Collections.ArrayList位于32位和64位Windows中不同位置的问题。我的32位Excel隐式尝试在32位Win将其存储的位置中找到它,但是由于我具有64位Win,所以我也遇到了一个问题:/我收到错误-2146232576(80131700)。

–ZygD
18年8月14日在13:42

谢谢普拉桑!替代其他蛮力方法的明智选择。

– pstraton
19-09-17在22:59

#5 楼

自然数(字符串)快速排序

只需要讨论主题即可。
通常,如果您使用数字对字符串进行排序,则会得到如下所示的结果:

    Text1
    Text10
    Text100
    Text11
    Text2
    Text20


但是您确实希望它能够识别数字值并进行排序像

    Text1
    Text2
    Text10
    Text11
    Text20
    Text100


这里是怎么做的...

注意:


我偷了很久以前就可以从Internet上进行快速排序了,不知道现在在哪里...
我也翻译了最初也是用C语言从Internet编写的CompareNaturalNum函数。
与其他Q-Sorts的区别:如果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排序-必须将其添加为选项

– Mark Nold
16年5月24日在13:26

#6 楼

我发布了一些代码以回答有关StackOverflow的一个相关问题:

在VBA中排序多维数组

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


矢量数组Quicksort;
多列数组QuickSort;
BubbleSort。

Alain优化的Quicksort非常有光泽:我只是做了一个基本的拆分-和递归,但是上面的代码示例具有“选通”功能,可以减少重复值的冗余比较。另一方面,我为Excel编写代码,并且防御代码还有更多内容-警告,如果您的数组包含有害的“ Empty()”变体,则您将需要它,这会破坏您的While。请注意比较运算符,并将您的代码陷入无限循环中。

请注意,快速排序算法-和任何递归算法-可以填充堆栈并使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
'Sort a 2-Dimensional array
' Sample Usage: sort arrData by the contents of column 3
'
'   QuickSortArray arrData, , , 3
'
'Posted by Jim Rech 10/20/98 Excel.Programming
'Modifications, Nigel Heffernan:
'       ' Escape failed comparison with empty variant
'       ' Defensive coding: check inputs
Dim i           As Long
Dim j           As Long
Dim varMid      As Variant
Dim arrRowTemp  As Variant
Dim lngColTemp  As Long
 If IsEmpty(SortArray) Then
     Exit Sub
 End If
 If InStr(TypeName(SortArray), "()") < 1 Then  'IsArray() is somewhat broken:  Look for brackets in the type name
     Exit Sub
 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 ' no sorting required
     Exit Sub
 End If
 i = lngMin
 j = lngMax
 varMid = Empty
 varMid = SortArray((lngMin + lngMax) \ 2, lngColumn)
 ' We  send 'Empty' and invalid data items to the end of the list:
 If IsObject(varMid) Then  ' note that we don't check isObject(SortArray(n)) - varMid might pick up a valid default member or property
     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
         ' Swap the rows
         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


#7 楼

您不想要基于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()这个函数,它对调试时快速检查任何二维数组很有用。

–lucas0x7B
11年5月25日在11:19



#8 楼

我不知道您会对这个数组排序代码说什么。它实现起来很快,并且可以完成工作……尚未针对大型阵列进行测试。它适用于一维数组,对于多维附加值,需要构建重定位矩阵(维数要比初始数组少一维)。

       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要求除泡沫之外的其他东西。

– Michiel van der Blonk
2015年11月23日,下午1:34

#9 楼

我认为我的代码(经过测试)更加“受过教育”,假设越简单越好。

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


评论


这是什么样的?而为什么说它是“受过教育的”呢?

–not2qubit
17-10-29在9:54

通过阅读代码,似乎可以将整个二维数组(取自Excel工作表)“排序”在整个数组(而不是某个特定维度)上。因此,值将更改其维数索引。然后将结果放回工作表。

–ZygD
18年8月14日在14:02

虽然该代码可能适用于简单情况,但是此代码存在很多问题。我注意到的第一件事是在各处使用Double而不是Long。其次,它不考虑范围是否有多个区域。排序矩形似乎没有用,当然也不是OP要求的(特别是说没有本机Excel / .Net解决方案)。此外,如果将越简单越好,则越受过“良好的教育”,那么使用内置的Range.Sort()函数不是最好的吗?

– Profex
18-10-23在17:05



#10 楼

这就是我用来在内存中排序的东西-可以很容易地扩展它来排序数组。

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


#11 楼

堆排序实现。一个O(n log(n))(平均情况和最坏情况),都存在不稳定的排序算法。

用于: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


#12 楼

@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://stackoverflow.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


#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(),"|")