如何改进这种排序算法？答案

【问题标题】：How can I improve this sorting algorithm?如何改进这种排序算法？
【发布时间】：2022-01-14 01:12:07
【问题描述】：

我需要什么：

我经常需要重新排列多维数组，尤其是时间戳。为此，我需要一个例程，这会产生永久的排序顺序。由于数据可能很大，因此它必须尽可能高效。

我想对我目前的工作有一些反馈。我试图理解排序数组的实用性。我不是程序员，请耐心等待。 :)

我会感谢每一个帮助/提示！我可能会学习一些新东西。

到目前为止我的努力是什么：

一开始我采用了冒泡排序算法。它做了需要做的事情，但它的性能非常低。对 582 行 114 列中的列进行排序需要 20 多秒。

代码适用于单列和多列数组。我使用正则表达式，所以请记住代码末尾的小函数。

我已经逐步注释了我的代码，我希望它仍然可读。

我知道 QuickSort 会快得多，但我还不明白如何让这个算法永久/稳定。我找到了这个解决方案Sorting a multidimensionnal array in VBA，但正如所说，它不是永久性的。

尤其是对于 Excel，我知道将数组复制到工作表并在那里对其进行排序的方法。我的目标是避免这种解决方案。 :)

'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+  BubbleSort_Array
'+
'+  Sort algorithm: BubbleSort
'+  Sorts by: 1. numbers, 2. dates, 3. Zeichenketten (also with consecutive number, e.g. "Book1,Book2,Book3..."; Capital letters before small letters)
'+  Parameter "Data": Requires an array (VARIANT) with one or more columns and rows, by reference
'+  Paramater "Column" is a LONG, follows the counting by "Option Base 0" (first column = 0)
'+  Parameter "Direction" is an EXCEL-based constant, that determines the sortdirection (ascending/descending)
'+
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    Public Sub BubbleSort_Array( _
        ByRef Data() As Variant, _
        Optional Column As Long = -1, _
        Optional Direction As XlSortOrder = 1 _
            )
        
        Dim InnerIndex As Long 'common variable, for the inner loop
        Dim OuterIndex As Long 'common variable, for the outer loop
        Dim SwapItem As Variant 'variable to temporarily save content, that could be swapped with another item
        Dim SwapItem2 As Variant 'variable to temporarily save content, that could be swapped with another item
        
        Dim ErrNum As Long 'variable for error number of the ERR-object
        Dim lngRow As Long 'common variable for the rows of an array
        Dim lngColumn As Long 'common variable for the column of an array
            
        Dim colNumber As New Collection 'variable to save a part of digits from an entry
        Dim colText As New Collection 'variable to save a part of text from an entry
        Dim colDates As New Collection 'variable to save dates from an entry
        
        Dim SortIndex() As Variant 'array for sorting and mapping the specified COLUMN
        Dim CopyData() As Variant 'array for the original data, but sorted
    
'Check, whether the given array is a one- or multi-column array
    
        On Error Resume Next
        
            ErrNum = UBound(Data, 2)
            ErrNum = Err.Number
            
        On Error GoTo 0
    
'If there is an error and the parameter COLUMN is still -1 the parameter DATA is an one-column-array
    
        If ErrNum > 0 And Column = -1 Then

'Outer loop

            For OuterIndex = LBound(Data) To UBound(Data)
            
'Inner loop

                For InnerIndex = LBound(Data) To UBound(Data)
                    
'Execute the following statement as long the current index is not the last one (it would throw an error 9 by trying to access the next item)
                    
                    If InnerIndex < UBound(Data) Then
        
'To differentiate between the values
'Check, whether the value and the next value are dates
        
                        If VBA.IsDate(Data(InnerIndex)) And VBA.IsDate(Data(InnerIndex + 1)) Then
                        
'Save the dates in a temporary collection
        
                            colDates.Add VBA.CDate(Data(InnerIndex)), "date1"
                            colDates.Add VBA.CDate(Data(InnerIndex + 1)), "date2"
                            
                        Else
        
'If both values are not dates, split the value in case it is a STRING with an number at the end
'like "Paper1", "Paper2" etc.
        
                            colNumber.Add RegEx_Replace(Data(InnerIndex), ".*(\d+$)", "$1"), "current"
                            colNumber.Add RegEx_Replace(Data(InnerIndex + 1), ".*(\d+$)", "$1"), "next"
                            colText.Add RegEx_Replace(Data(InnerIndex), "(.*)\d+$", "$1"), "current"
                            colText.Add RegEx_Replace(Data(InnerIndex + 1), "(.*)\d+$", "$1"), "next"
                            
                        End If
        
'Check, whether the sortdirection is ascending
        
                        If Direction = xlAscending Then

'Sort by date

                            If VBA.IsDate(Data(InnerIndex)) And VBA.IsDate(Data(InnerIndex + 1)) Then

'Check the items depending from the sortdirection

                                If VBA.CDbl(colDates("date1")) > VBA.CDbl(colDates("date2")) Then

'In case the first item is bigger then the second, swap the items

                                    SwapItem = Data(InnerIndex)
                                    Data(InnerIndex) = Data(InnerIndex + 1)
                                    Data(InnerIndex + 1) = SwapItem
                                    
                                End If

'Sort by strings with consecutive number

                            ElseIf VBA.IsNumeric(colNumber("current")) And VBA.IsNumeric(colNumber("next")) _
                                And (colText("current") = colText("next")) Then

'In case the first item is bigger then the second, swap the items

                                If colNumber("current") > colNumber("next") Then
                                
                                    SwapItem = Data(InnerIndex)
                                    Data(InnerIndex) = Data(InnerIndex + 1)
                                    Data(InnerIndex + 1) = SwapItem
                                    
                                End If
            
                            Else

'Sort by strings
'In case the first item is bigger then the second, swap the items

                                If Data(InnerIndex) > Data(InnerIndex + 1) Then
                                
                                    SwapItem = Data(InnerIndex)
                                    Data(InnerIndex) = Data(InnerIndex + 1)
                                    Data(InnerIndex + 1) = SwapItem
                                    
                                End If
                            
                            End If

'Sort descending

                        Else

'Sort descending

'Sort by date

                            If VBA.IsDate(Data(InnerIndex)) And VBA.IsDate(Data(InnerIndex + 1)) Then

                                If VBA.CDbl(colDates("date1")) < VBA.CDbl(colDates("date2")) Then
                                
'In case the first item is smaller then the second, swap the items

                                    SwapItem = Data(InnerIndex)
                                    Data(InnerIndex) = Data(InnerIndex + 1)
                                    Data(InnerIndex + 1) = SwapItem
                                    
                                End If

'Sort by strings with consecutive number

                            ElseIf VBA.IsNumeric(colNumber("current")) And VBA.IsNumeric(colNumber("next")) And _
                                (colText("current") = colText("next")) Then
            
'In case the first item is smaller then the second, swap the items

                                If colNumber("current") < colNumber("next") Then
                                
                                    SwapItem = Data(InnerIndex)
                                    Data(InnerIndex) = Data(InnerIndex + 1)
                                    Data(InnerIndex + 1) = SwapItem
                                    
                                End If
                                
                            Else

'Sort by strings
'In case the first item is smaller then the second, swap the items

                                If Data(InnerIndex) < Data(InnerIndex + 1) Then
                                
                                    SwapItem = Data(InnerIndex)
                                    Data(InnerIndex) = Data(InnerIndex + 1)
                                    Data(InnerIndex + 1) = SwapItem
                                    
                                End If
                            
                            End If
                            
                        End If
                        
                    End If
                    
                    Set colNumber = Nothing
                    Set colText = Nothing
                    Set colDates = Nothing
                    
                Next
                
            Next
        
        Else

'Resize the array SortIndex for sorting the specified COLUMN
'Needs two columns: One for the index of the original data, and one for the values to be sorted

            ReDim SortIndex(UBound(Data, 1), 1)
            
            For InnerIndex = LBound(Data, 1) To UBound(Data, 1)

'Save index of the original data

                SortIndex(InnerIndex, 0) = InnerIndex

'Save values of the specified COLUMN

                SortIndex(InnerIndex, 1) = Data(InnerIndex, Column)
                
            Next
            
'Outer loop

            For OuterIndex = LBound(SortIndex, 1) To UBound(SortIndex, 1)

'Inner loop

                For InnerIndex = LBound(SortIndex, 1) To UBound(SortIndex, 1)

'Execute the following statement as long the current index is not the last one (it would throw an error 9 by trying to access the next item)

                    If InnerIndex < UBound(SortIndex, 1) Then

'To differentiate between the values
'Check, whether the value and the next value are dates

                        If VBA.IsDate(SortIndex(InnerIndex, 1)) And VBA.IsDate(SortIndex(InnerIndex + 1, 1)) Then
                    
'Save the dates in a temporary collection

                            colDates.Add VBA.CDate(SortIndex(InnerIndex, 1)), "date1"
                            colDates.Add VBA.CDate(SortIndex(InnerIndex + 1, 1)), "date2"
                            
                        Else
                        
'If both values are not dates, split the value in case it is a STRING with an number at the end
'like "Paper1", "Paper2" etc.

                            colNumber.Add RegEx_Replace(SortIndex(InnerIndex, 1), ".*(\d+$)", "$1"), "current"
                            colNumber.Add RegEx_Replace(SortIndex(InnerIndex + 1, 1), ".*(\d+$)", "$1"), "next"
                            colText.Add RegEx_Replace(SortIndex(InnerIndex, 1), "(.*)\d+$", "$1"), "current"
                            colText.Add RegEx_Replace(SortIndex(InnerIndex + 1, 1), "(.*)\d+$", "$1"), "next"
                            
                        End If

'Check the sortdirection

                        If Direction = xlAscending Then

'Sort by date

                            If VBA.IsDate(SortIndex(InnerIndex, 1)) And VBA.IsDate(SortIndex(InnerIndex + 1, 1)) Then
            
                               If VBA.CDbl(colDates("date1")) > VBA.CDbl(colDates("date2")) Then

'In case the first item is bigger then the second, swap the items

                                    SwapItem = SortIndex(InnerIndex, 0)
                                    SwapItem2 = SortIndex(InnerIndex, 1)
                                    SortIndex(InnerIndex, 0) = SortIndex(InnerIndex + 1, 0)
                                    SortIndex(InnerIndex, 1) = SortIndex(InnerIndex + 1, 1)
                                    SortIndex(InnerIndex + 1, 0) = SwapItem
                                    SortIndex(InnerIndex + 1, 1) = SwapItem2
                                    
                                End If
                                
'Sort by strings with consecutive numbers

                            ElseIf VBA.IsNumeric(colNumber("current")) And VBA.IsNumeric(colNumber("next")) _
                                And (colText("current") = colText("next")) Then
                            
'In case the first item is bigger then the second, swap the items

                                If colNumber("current") > colNumber("next") Then
                                
                                    SwapItem = SortIndex(InnerIndex, 0)
                                    SwapItem2 = SortIndex(InnerIndex, 1)
                                    SortIndex(InnerIndex, 0) = SortIndex(InnerIndex + 1, 0)
                                    SortIndex(InnerIndex, 1) = SortIndex(InnerIndex + 1, 1)
                                    SortIndex(InnerIndex + 1, 0) = SwapItem
                                    SortIndex(InnerIndex + 1, 1) = SwapItem2
                                    
                                End If
            
                            Else

'Sort by strings
'In case the first item is bigger then the second, swap the items

                                If SortIndex(InnerIndex, 1) > SortIndex(InnerIndex + 1, 1) Then
                                
                                    SwapItem = SortIndex(InnerIndex, 0)
                                    SwapItem2 = SortIndex(InnerIndex, 1)
                                    SortIndex(InnerIndex, 0) = SortIndex(InnerIndex + 1, 0)
                                    SortIndex(InnerIndex, 1) = SortIndex(InnerIndex + 1, 1)
                                    SortIndex(InnerIndex + 1, 0) = SwapItem
                                    SortIndex(InnerIndex + 1, 1) = SwapItem2
                                    
                                End If
                            
                            End If
                            
                        Else

'Sort descending
'Sort by dates

                            If VBA.IsDate(SortIndex(InnerIndex, 1)) And VBA.IsDate(SortIndex(InnerIndex + 1, 1)) Then

'In case the first item is smaller then the second, swap the items

                               If VBA.CDbl(colDates("date1")) < VBA.CDbl(colDates("date2")) Then
                               
                                    SwapItem = SortIndex(InnerIndex, 0)
                                    SwapItem2 = SortIndex(InnerIndex, 1)
                                    SortIndex(InnerIndex, 0) = SortIndex(InnerIndex + 1, 0)
                                    SortIndex(InnerIndex, 1) = SortIndex(InnerIndex + 1, 1)
                                    SortIndex(InnerIndex + 1, 0) = SwapItem
                                    SortIndex(InnerIndex + 1, 1) = SwapItem2
                                End If
  
'Sort by strings with consecutive numbers

                            ElseIf VBA.IsNumeric(colNumber("current")) And VBA.IsNumeric(colNumber("next")) And _
                                (colText("current") = colText("next")) Then
            
'In case the first item is smaller then the second, swap the items

                                If colNumber("current") < colNumber("next") Then
                                    SwapItem = SortIndex(InnerIndex, 0)
                                    SwapItem2 = SortIndex(InnerIndex, 1)
                                    SortIndex(InnerIndex, 0) = SortIndex(InnerIndex + 1, 0)
                                    SortIndex(InnerIndex, 1) = SortIndex(InnerIndex + 1, 1)
                                    SortIndex(InnerIndex + 1, 0) = SwapItem
                                    SortIndex(InnerIndex + 1, 1) = SwapItem2
                                End If
                                
                            Else

'Sort by strings

                                If SortIndex(InnerIndex, 1) < SortIndex(InnerIndex + 1, 1) Then

'In case the first item is smaller then the second, swap the items

                                    SwapItem = SortIndex(InnerIndex, 0)
                                    SwapItem2 = SortIndex(InnerIndex, 1)
                                    SortIndex(InnerIndex, 0) = SortIndex(InnerIndex + 1, 0)
                                    SortIndex(InnerIndex, 1) = SortIndex(InnerIndex + 1, 1)
                                    SortIndex(InnerIndex + 1, 0) = SwapItem
                                    SortIndex(InnerIndex + 1, 1) = SwapItem2
                                    
                                End If
                            
                            End If
                            
                        End If
                        
                    End If
                    
                    Set colNumber = Nothing
                    Set colText = Nothing
                    Set colDates = Nothing
                    
                Next
            Next
    
'Resize a new array with the same size like the original DATA

            ReDim CopyData(UBound(Data, 1), UBound(Data, 2))
            
'Write the data according to the array SortIndex (= sorts the whole original data)

            For lngRow = LBound(Data, 1) To UBound(Data, 1)
                
                For lngColumn = LBound(Data, 2) To UBound(Data, 2)
                
                    CopyData(lngRow, lngColumn) = Data(SortIndex(lngRow, 0), lngColumn)
                
                Next
                    
            Next
            
'Overwrite the original data with the sorted data

            For lngRow = LBound(Data, 1) To UBound(Data, 1)
                
                For lngColumn = LBound(Data, 2) To UBound(Data, 2)
                
                    Data(lngRow, lngColumn) = CopyData(lngRow, lngColumn)
                
                Next
                    
            Next
            
        End If
        
    End Sub
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+  RegEx_Replace
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    
    Public Function RegEx_Replace( _
        varString As Variant, _
        strSearchPattern As String, _
        strReplaceString As String, _
        Optional blnCase_Insensitive As Boolean = True, _
        Optional blnGlobalSearch As Boolean = True, _
        Optional blnMultiLine As Boolean = False _
        ) As String
        
        Dim RegEx As Object
        
        Set RegEx = CreateObject("vbscript.regexp")

        With RegEx
            .IgnoreCase = blnCase_Insensitive
            .Global = blnGlobalSearch
            .MultiLine = blnMultiLine
            .Pattern = strSearchPattern
        End With
        
        RegEx_Replace = RegEx.Replace(varString, strReplaceString)
        
    End Function

【问题讨论】：

有很多算法比冒泡排序更好（需要 O(n^2) 时间）。
Excel有自己的排序功能，为什么要自己写排序算法呢？
如果你想通过 VBA 做到这一点，那么我建议你使用ArrayList and its Sort method
为什么要避免使用“excel工作表法”。它对于复杂的多维排序非常有效且有用。您可以轻松地将数据写入/读取 VBA 多维数组；并在您随后删除的临时隐藏工作表上进行排序。它既快速又稳定。
@trincot 我已经在我的私人电脑上测试了 ArrayList。这太好了。不幸的是，即使安装了较新的版本，它也需要 NET Framework 3.5。在我公司的电脑上，我不能自己安装软件。

标签： arrays excel vba algorithm sorting

【解决方案1】：

这是一种略有不同的方法 - 将一些功能分解为单独的方法，但主 Sub 具有与您的相似的签名（带有一个附加参数）


'run some tests
Sub Tester()

    Dim arr
    
    BubbleSort_Array Array(), 1 'empty array: does nothing
    
    arr = Array(5, 4, 1, 3, 2)
    BubbleSort_Array arr, 1
    [P1].Resize(1, UBound(arr) + 1).Value = arr
    
    '1-dimensional array
    arr = Array("1 Title", "2 Title", "10 Title", "33 Title", "16 Title", "blah")
    BubbleSort_Array arr, 1    'sort raw values
    [P2].Resize(1, UBound(arr) + 1).Value = arr
    
    arr = Array("1 Title", "2 Title", "10 Title", "33 Title", "16 Title", "blah")
    BubbleSort_Array arr, 1, "SortOnVal"  'sort on Val() transformation
    [P3].Resize(1, UBound(arr) + 1).Value = arr
    
    arr = Array("1 Title", "2 Title", "10 Title", "33 Title", "16 Title", "blah")
    BubbleSort_Array arr, 1, "SortOnVal", xlDescending 'sort on Val() transformation, descending
    [P4].Resize(1, UBound(arr) + 1).Value = arr
    
    '2-dimensional array (from A1:N22)
    arr = [A1].CurrentRegion.Value
    BubbleSort_Array arr, 3    'sort 2D array on third column ("Val1", "Val2",...."Val22")
    [A25].Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr  'sort is "ascibetical"
    
    arr = [A1].CurrentRegion.Value
    BubbleSort_Array arr, 3, "NumberOnly"   'sort 2D array on third column, after extracting a number where present
    [A49].Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr  'sort looks correct
    
End Sub

'Sort array `data` in-place, using optional column position if 2D array
'Optional `ParseFunction` parameter is the name of a single-input function to transform values prior to sorting
Sub BubbleSort_Array(ByRef data As Variant, Optional Column As Long = -1, _
                            Optional ParseFunction As String = "", _
                            Optional Direction As XlSortOrder = 1)
    
    Dim dims As Long, lbr As Long, lbc As Long, ubr As Long, ubc As Long, i As Long, j As Long
    Dim arrSort, tmp, tmp2, swap As Boolean, arrOut
    
    dims = Dimensions(data)   'check input array dimensions
    Debug.Print "dims", dims
    If dims < 1 Or dims > 2 Then Exit Sub
    
    lbr = LBound(data, 1)
    ubr = UBound(data, 1)
    If dims = 1 Then data = Make2D(data) 'normalize input to 2D array (single column)
    lbc = LBound(data, 2)
    ubc = UBound(data, 2)
    If Column = -1 Then Column = lbc 'sort defaults to first column
    
    'make an array for sorting: first column is values to sort on, second is row indexes from `data`
    ' advantage is you're shuffling fewer items when sorting, and expensive transformations only run once
    ReDim arrSort(lbr To ubr, 1 To 2)
    For i = lbr To ubr
        tmp = data(i, Column) 'value to sort on
        If Len(ParseFunction) > 0 Then tmp = Application.Run(ParseFunction, tmp) 'custom transformation?
        arrSort(i, 1) = tmp
        arrSort(i, 2) = i
    Next i
    
    'now sort the array...
    For i = lbr To ubr - 1
        For j = i + 1 To ubr
            swap = IIf(Direction = xlAscending, arrSort(i, 1) > arrSort(j, 1), _
                                                arrSort(i, 1) < arrSort(j, 1))
            If swap Then
                tmp = arrSort(j, 1)         'swap positions in the "comparison" array
                tmp2 = arrSort(j, 2)
                arrSort(j, 1) = arrSort(i, 1)
                arrSort(j, 2) = arrSort(i, 2)
                arrSort(i, 1) = tmp
                arrSort(i, 2) = tmp2
            End If
        Next j
    Next i
    
    ReDim arrOut(lbr To ubr, lbc To ubc)  'size the output array
    'using the sorted array, copy data from the original array
    For i = lbr To ubr
        For j = lbc To ubc
            arrOut(i, j) = data(arrSort(i, 2), j)
        Next j
    Next i
    
    If dims = 1 Then arrOut = Make1D(arrOut) 'switch back to 1D if input was 1D
    
    data = arrOut 'replace the input array in-place
End Sub

'return result of Val()
Function SortOnVal(v)
    SortOnVal = Val(v)
End Function

'extract the first *whole* number from string `v`
Function NumberOnly(v) As Long
    Dim rv, i, c
    For i = 1 To Len(v)
        c = Mid(v, i, 1)
        If IsNumeric(c) Then
            rv = rv & c
        Else
            If Len(rv) > 0 Then Exit For
        End If
    Next i
    If Len(rv) = 0 Then rv = 0
    NumberOnly = CLng(rv)
End Function


'----Helper functions

'find the dimension of an array
Function Dimensions(data As Variant)
    Dim d As Long, ub
    d = 1
    Do
        ub = Empty
        On Error Resume Next
        'Debug.Print d, LBound(data, d), UBound(data, d)
        ub = UBound(data, d)
        On Error GoTo 0
        If ub = -1 Or IsEmpty(ub) Then Exit Do 'also checking for undimensioned case...
        d = d + 1
    Loop
    Dimensions = d - 1
End Function

'transform a 1-D array into a 2D array (single-column)
Function Make2D(arr)
    Dim i As Long, arrOut
    ReDim arrOut(LBound(arr) To UBound(arr), 1 To 1)
    For i = LBound(arr) To UBound(arr)
        arrOut(i, 1) = arr(i)
    Next i
    Make2D = arrOut
End Function

'transform a single-column 2-D array into a 1D array
Function Make1D(arr)
    Dim i As Long, arrOut
    ReDim arrOut(LBound(arr) To UBound(arr))
    For i = LBound(arr) To UBound(arr)
        arrOut(i) = arr(i, 1)
    Next i
    Make1D = arrOut
End Function

【讨论】：

非常感谢。我不知道有一个函数可以根据变量值调用函数。我测试了你的代码，性能很好，但似乎不稳定。我已经对姓名和姓氏的列表进行了排序，但它没有包含第一个排序。 :(
为什么要用这一行 "swap = IIf(Direction = xlAscending, arrSort(i, 1) > arrSort(j, 1), arrSort(i, 1)
忘记了“稳定”位 - 我会尝试使用reddit.com/r/vba/comments/k12p50/… 来调整它，swap=... 用于根据排序方向是升序还是降序来确定是否交换行。
Willimans 感谢您的链接和链接。

【解决方案2】：

奇怪，我以为我昨天上传了这张截图：

如您所见，您可以检查“数据”功能区、“过滤和排序”选项，然后就可以使用了。

【讨论】：

【解决方案3】：

所以，我决定使用 excel-worksheet-method。感谢 Dominique 和 Ron Rosenfeld。

除了良好的性能之外，它还可以正确地对日期和数字进行排序。

这是我的代码：

'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+  Sort_by_Excel
'+
'+  Sort algorithm: Excel
'+  Sorts by: 1. numbers, 2. dates, 3. strings
'+  Parameter "arrData": Requires an array (VARIANT) with one or more columns and rows, by reference
'+  Parameter "wsWorksheet": a worksheet to copy and sort the data
'+  Paramater "Column" is a LONG, follows the normal counting for worksheets (first column = 1)
'+  Parameter "SortDirection" is an EXCEL-based constant, that determines the sortdirection (ascending/descending)
'+
'+  Current performance: 582 rows and 114 columns are sorted in <1 sec
'+  Works with Option Base 0 and 1
'+
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Public Sub Sort_by_Excel( _
    ByRef arrData As Variant, _
    wsWorksheet As Worksheet, _
    Optional Column As Long, _
    Optional SortDirection As XlSortOrder = 1 _
    )

    Dim rngKey As Range
    Dim rngSortRange As Range
    Dim lngRow As Long
    Dim lngColumn As Long
    Dim lngErrNumber As Long

'Check, whether it is a single-column array or multi-column array

    On Error Resume Next
    
    lngErrNumber = UBound(arrData, 2)
    lngErrNumber = Err.Number
    
    On Error GoTo 0
    
'Code for multi-column array

    If lngErrNumber = 0 Then

'If COLUMN is not in the range of existing columns leave the sub, data is still unsorted

        If Column < LBound(arrData, 1) + 1 - LBound(arrData, 1) And Column > UBound(arrData, 2) + 1 - LBound(arrData, 2) Then Exit Sub

        With wsWorksheet

'Remove everything from the worksheet

            .Cells.Clear
            
'Define a key cell for sorting (the first cell of to be sorted column)

            Set rngKey = .Cells(1, Column)
    
'Define the range, where the data will be copied to
'Size of arrData

            Set rngSortRange = .Range( _
                .Cells(1, 1), .Cells( _
                    UBound(arrData, 1) + 1 - LBound(arrData, 1), _
                    UBound(arrData, 2) + 1 - LBound(arrData, 2)) _
                )
                
        End With
            
        With rngSortRange

'Copy the data to the range

            .Value = arrData

'Sort the range

            .CurrentRegion.Sort _
                Key1:=rngKey, _
                Order1:=SortDirection, _
                Orientation:=xlTopToBottom

'Overwrite the original data

            For lngRow = 1 To .Rows.Count
        
                For lngColumn = 1 To .Columns.Count
            
                    arrData((lngRow - 1) + LBound(arrData, 1), (lngColumn - 1) + LBound(arrData, 2)) = .Cells(lngRow, lngColumn).Value
                
                Next
            
            Next
        
        End With
    
    Else

'Code for single-column array, same as above

        With wsWorksheet
            .Cells.Clear
            Set rngKey = .Cells(1, 1)
            Set rngSortRange = .Range( _
                .Cells(1, 1), .Cells(UBound(arrData) + 1, 1) _
                )
        End With
            
        With rngSortRange

'Copy the data to range, original array has to transposed (rotate from horizontal to vertical)

            .Value = Application.Transpose(arrData)
            .CurrentRegion.Sort _
                Key1:=rngKey, _
                Order1:=SortDirection, _
                Orientation:=xlTopToBottom

'Overwrite the original data with the sorted data

            For lngRow = 1 To .Rows.Count
            
                arrData((lngRow - 1) + LBound(arrData, 1)) = .Cells(lngRow, 1).Value
            
            Next
        
        End With
        
    End If
    
End Sub

【讨论】：