Excel VBA 按降序對數字數組進行排序的最快方法？

Question

按降序對數字數組（1000-10000 個數字，但可能會有所不同）進行排序的最快方法（就計算時間而言）是什么？ 據我所知，Excel 內置函數並不是很高效，內存排序應該比 Excel 函數快很多。

請注意，我無法在電子表格上創建任何內容，所有內容都必須僅在內存中存儲和排序。

Answer 1

您可以使用System.Collections.ArrayList ：

Dim arr As Object
Dim cell As Range

Set arr = CreateObject("System.Collections.ArrayList")

' Initialise the ArrayList, for instance by taking values from a range:
For Each cell In Range("A1:F1")
    arr.Add cell.Value
Next

arr.Sort
' Optionally reverse the order
arr.Reverse

這使用快速排序。

Answer 2

為了讓人們不必單擊我剛剛創建的鏈接，這里是 Siddharth 評論中的精彩示例之一。

Option Explicit
Option Compare Text

' Omit plngLeft & plngRight; they are used internally during recursion
Public Sub QuickSort(ByRef pvarArray As Variant, Optional ByVal plngLeft As Long, Optional ByVal plngRight As Long)
    Dim lngFirst As Long
    Dim lngLast As Long
    Dim varMid As Variant
    Dim varSwap As Variant

    If plngRight = 0 Then
        plngLeft = LBound(pvarArray)
        plngRight = UBound(pvarArray)
    End If
    lngFirst = plngLeft
    lngLast = plngRight
    varMid = pvarArray((plngLeft + plngRight) \ 2)
    Do
        Do While pvarArray(lngFirst) < varMid And lngFirst < plngRight
            lngFirst = lngFirst + 1
        Loop
        Do While varMid < pvarArray(lngLast) And lngLast > plngLeft
            lngLast = lngLast - 1
        Loop
        If lngFirst <= lngLast Then
            varSwap = pvarArray(lngFirst)
            pvarArray(lngFirst) = pvarArray(lngLast)
            pvarArray(lngLast) = varSwap
            lngFirst = lngFirst + 1
            lngLast = lngLast - 1
        End If
    Loop Until lngFirst > lngLast
    If plngLeft < lngLast Then QuickSort pvarArray, plngLeft, lngLast
    If lngFirst < plngRight Then QuickSort pvarArray, lngFirst, plngRight
End Sub

Answer 3

如果你想要高效的算法，那么看看Timsort 。 合並排序的改編解決了它的問題。

Case    Timsort     Introsort   Merge sort  Quicksort   Insertion sort  Selection sort
Best    Ɵ(n)        Ɵ(n log n)  Ɵ(n log n)  Ɵ(n)        Ɵ(n^2)          Ɵ(n)
Average Ɵ(n log n)  Ɵ(n log n)  Ɵ(n log n)  Ɵ(n log n)  Ɵ(n^2)          Ɵ(n^2)  
Worst   Ɵ(n log n)  Ɵ(n log n)  Ɵ(n log n)  Ɵ(n^2)      Ɵ(n^2)          Ɵ(n^2)  

然而，1k - 10k 的數據條目對於您來說太少了，您不必擔心內置的搜索效率。

---

示例：如果您有從A 列到 D列的數據，並且標題位於第 2 行，並且您希望按B 列排序。

Dim lastrow As Long
lastrow = Cells(Rows.Count, 2).End(xlUp).Row
Range("A3:D" & lastrow).Sort key1:=Range("B3:B" & lastrow), _
   order1:=xlAscending, Header:=xlNo

Answer 4

我成功地使用了 Shell 排序算法。 使用由 VBA Rnd() 函數生成的數組測試 N=10000 時眨眼間運行 - 不要忘記使用 Randomize 語句生成測試數組。 對於我正在處理的元素數量來說，它很容易實現並且足夠簡短和高效。 代碼注釋中給出了參考。

' Shell sort algorithm for sorting a double from largest to smallest.
' Adopted from "Numerical Recipes in C" aka NRC 2nd Edition p330ff.
' Speed is on the range of N^1.25 to N^1.5 (somewhere between bubble and quicksort)
' Refer to the NRC reference for more details on efficiency.
' 
Private Sub ShellSortDescending(ByRef a() As Double, N As Integer)

    ' requires a(1..N)

    Debug.Assert LBound(a) = 1

    ' setup

    Dim i, j, inc As Integer
    Dim v As Double
    inc = 1

    ' determine the starting incriment

    Do
        inc = inc * 3
        inc = inc + 1
    Loop While inc <= N

    ' loop over the partial sorts

    Do
        inc = inc / 3

        ' Outer loop of straigh insertion

        For i = inc + 1 To N
            v = a(i)
            j = i

            ' Inner loop of straight insertion
            ' switch to a(j - inc) > v for ascending

            Do While a(j - inc) < v
                a(j) = a(j - inc)
                j = j - inc
                If j <= inc Then Exit Do
            Loop
            a(j) = v
        Next i
    Loop While inc > 1
End Sub

Answer 5

我知道指定的 OP 不使用工作表，但值得注意的是，創建一個新的工作表，將其用作便箋簿以使用工作表功能進行排序，然后清理時間少於 2 倍。但你也有排序工作表函數的參數提供的所有靈活性。

在我的系統上，對於@tannman357 的非常好的遞歸例程，差異是 55 毫秒，對於下面的方法，差異是 96 毫秒。 這些是幾次運行的平均時間。

Sub rangeSort(ByRef a As Variant)
Const myName As String = "Module1.rangeSort"
Dim db As New cDebugReporter
    db.Report caller:=myName

Dim r As Range, va As Variant, ws As Worksheet

  quietMode qmON
  Set ws = ActiveWorkbook.Sheets.Add
  Set r = ws.Cells(1, 1).Resize(UBound(a), 1)
  r.Value2 = rangeVariant(a)
  r.Sort Key1:=r.Cells(1), Order1:=xlDescending
  va = r.Value2
  GetColumn va, a, 1
  ws.Delete
  quietMode qmOFF

End Sub

Function rangeVariant(a As Variant) As Variant
Dim va As Variant, i As Long

  ReDim va(LBound(a) To UBound(a), 0)

  For i = LBound(a) To UBound(a)
    va(i, 0) = a(i)
  Next i
  rangeVariant = va

End Function

Sub quietMode(state As qmState)
Static currentState As Boolean

  With Application

    Select Case state
    Case qmON
      currentState = .ScreenUpdating
      If currentState Then .ScreenUpdating = False
      .Calculation = xlCalculationManual
      .DisplayAlerts = False
    Case qmOFF
      If currentState Then .ScreenUpdating = True
      .Calculation = xlCalculationAutomatic
      .DisplayAlerts = True
    Case Else
    End Select

  End With
End Sub

Answer 6

很久以前我自己回答了這個問題，這意味着我不得不回到我的第一個 VBA 存檔文件。 所以我找到了這段舊代碼，這是我從一本書上拿來的。 首先，它將值（來自與表列相交的選擇）保存到數組 ar(x)，然后將它們從小到大排序。 要排序有 2 個 bucles，第一個 (Do Loop Until sw=0) 和第二個 (For x=1 To n Next) 將值 a(x) 與值 a(x+1) 進行比較，保持在 a( x) 中最大的數和 ar(x+1) 中最小的數。 第一個 bucle 重復，直到從最小到最大排序。 我實際上使用此代碼在預算列 (TblPpto[Descripcion]) 中的每個選定單元格上方插入一行。 希望能幫助到你！

Sub Sorting()
Dim ar() As Integer, AX As Integer
Set rng = Intersect(Selection, Range("TblPpto[Descripcion]")) 'Cells selected in Table column
n = rng.Cells.Count 'Number of rows
ReDim ar(1 To n)
x = 1
For Each Cell In rng.Cells
    ar(x) = Cell.Row 'Save rows numbers to array ar()
    x = x + 1
Next
Do 'Sort array ar() values
    sw = 0  'Condition to finish bucle
    For x = 1 To n - 1
        If ar(x) > ar(x + 1) Then 'If ar(x) is bigger
            AX = ar(x)            'AX gets bigger number
            ar(x) = ar(x + 1)     'ar(x) changes to smaller number
            ar(x + 1) = AX        'ar(x+1) changes to bigger number
            sw = 1                'Not finished sorting
        End If
    Next
Loop Until sw = 0
'Insert rows in TblPpto
fila = Range("TblPpto[#Headers]").Row
For x = n To 1 Step -1
    [TblPpto].Rows(ar(x) - fila).EntireRow.Insert
Next x
End Sub

Answer 7

trincot 代碼簡單地擴展為一個函數。 玩得開心！

Function sort1DimArray(thatArray As Variant, descending As Boolean) As Variant
Dim arr As Object, i As Long, j As Long`

Set arr = CreateObject("System.Collections.ArrayList")

For i = LBound(thatArray) To UBound(thatArray)
    arr.Add thatArray(i)
Next i

arr.Sort

If descending = True Then
    arr.Reverse
End If
'shortens empty spaces
For i = 0 To (arr.count - 1)
    If Not IsEmpty(arr.Item(i)) Then
        thatArray(j) = arr.Item(i)
        j = j + 1
    End If
Next i

ReDim Preserve thatArray(0 To (j - 1))
sort1DimArray = thatArray

End Function