Excel VBA Najszybszy sposób sortowania tablicy liczb w porządku malejącym?

Question

Jaki jest najszybszy (w sensie czasu obliczeniowego) sposób sortowania tablicy liczb (1000-10000 liczb, ale może się różnić) w porządku malejącym? O ile mi wiadomo, funkcje wbudowane programu Excel nie są naprawdę wydajne, a sortowanie w pamięci powinno być dużo szybsze niż funkcje programu Excel.

Pamiętaj, że nie mogę niczego utworzyć w arkuszu kalkulacyjnym, wszystko musi być zapisane i posortowane tylko w pamięci.

Answer 1

Po to, żeby ludzie nie musieli klikać linku, który właśnie zrobiłem, oto jeden z fantastycznych przykładów z komentarza Siddhartha.

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 2

Znam OP określony nie używając arkuszy ale jego warto zauważyć, że tworzenie nowego arkusza, używając go jako notatniku zrobić sortowania z funkcji arkusza, a następnie sprzątanie po jest dłuższy o mniej niż czynnik z 2. Ale masz także całą elastyczność dostarczoną przez parametry funkcji Sort WorkSheet.

W moim systemie różnica wyniosła 55 ms dla bardzo ładnej procedury rekursywnej przez @ tannman357 i 96 ms dla poniższej metody. Są to średnie czasy w kilku seriach.

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 3

Jeśli chcesz skuteczny algorytm, a następnie przyjrzeć Timsort. Jest to adaptacja sortowania scalającego, która naprawia jego problemy.

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) 

Jednak 1k - 10k danych wejściowych to zdecydowanie zbyt mało danych, aby się martwić o wbudowaną wydajność wyszukiwania.

---

Przykład: Jeśli masz dane z kolumny A do D i nagłówek jest w wierszu 2 i chcesz sortować według kolumnie 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

Można użyć 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 

ta wykorzystuje szybki sort.

Answer 5

Użyłem pomyślnie algorytmu sortowania skorupy. Uruchamia się w mgnieniu oka, gdy testowane jest na N = 10000 przy użyciu tablicy wygenerowanej za pomocą funkcji RBA() VBA - nie zapomnij użyć instrukcji Randomize do generowania macierzy testowych. To było łatwe do wdrożenia, krótkie i wystarczająco wydajne dla wielu elementów, z którymi miałem do czynienia. Odniesienia podano w komentarzach do kodu.

' 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