Excel VBA 按降序对数字数组进行排序的最快方法？

Question

What is the quickest way (in terms of computational time) to sort an array of numbers (1000-10000 numbers but could vary) in descending order? As far as I know the Excel build-in functions is not really efficient and in-memory sorting should be a lot faster than the Excel functions.

Note that I can not create anything on the spreadsheet, everything has to be stored and sorted in memory only.

Answer 1

You could use 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

This uses Quick Sort.

Answer 2

Just so that people don't have to click the link that I just did, here is one of the fantastic examples from Siddharth's comment.

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

If you want efficient algorithm, then take a look at Timsort . It is adaptation of merge sort that fixes it's problems.

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)  

However 1k - 10k data entries are far too little amount of data for you to worry about built in search efficiency.

---

Example: If you have data from column A to D and header is at row 2 and you want to sort by column 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

I have used the Shell sort algorithm successfully. Runs in the blink of an eye when tested for N=10000 using an array generated with VBA Rnd() function - don't forget to use the Randomize statement for generating test arrays. It was easy to implement and short and efficient enough for the number of elements I was dealing with. Reference is given in the code comments.

' 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

I know the OP specified not using worksheets but its worth noting that creating a new WorkSheet, using it as a scratch pad to do the sort with worksheet functions, then cleaning up after is longer by less than a factor of 2. But you also have all of the flexibility delivered by the parameters of the Sort WorkSheet Function.

On my system, the difference was 55 msec for the very nice recursive routine by @tannman357 and 96 msec for the method below. Those are average times over several runs.

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

I answered this question myself a long time ago, meaning I had to come back to my very first VBA archived files. So I found this old code, which I took from a book. First it saves values (from selection intersected with a table column) to array ar(x) then sort them from smallest to biggest. To sort there are 2 bucles, the first one (Do Loop Until sw=0) and the second one (For x=1 To n Next) compares value a(x) with value a(x+1), keeping in a(x) the biggest number and in ar(x+1) the smallest number. The first bucle repeats until is sorted form smallest to biggest. I actually used this code to insert a rows above every selected cell in a budget column (TblPpto[Descripcion]). Hope it helps!

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

The trincot code simply expanded as a function. Have fun with that!

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