Funkcja sortowania tablic VBA?

84

Szukam porządnej implementacji sortowania dla tablic w VBA. Preferowany byłby Quicksort. Lub inny algorytm sortowania inny niż bąbelkowy lub scalający byłby wystarczający.

Należy pamiętać, że ma to działać z MS Project 2003, więc należy unikać jakichkolwiek natywnych funkcji Excela i wszystkiego, co dotyczy .net.

Mark Nold
źródło
3
Może być ciekawie zajrzeć tutaj: rosettacode.org/wiki/Sorting_algorithms/Quicksort#VBA
MjrKusanagi
Dlaczego nie lubisz sortowania przez scalanie?
jwg

Odpowiedzi:

103

Spójrz tutaj :
Edycja: źródło odniesienia (allexperts.com) zostało zamknięte, ale oto odpowiednie komentarze autora :

W sieci dostępnych jest wiele algorytmów do sortowania. Najbardziej wszechstronnym i zwykle najszybszym jest algorytm Quicksort . Poniżej znajduje się odpowiednia funkcja.

Wywołaj to po prostu przekazując tablicę wartości (ciąg znaków lub liczb; nie ma to znaczenia) z dolną granicą tablicy (zwykle 0) i górną granicą tablicy (tj UBound(myArray).)

Przykład :Call QuickSort(myArray, 0, UBound(myArray))

Po myArrayzakończeniu zostanie posortowany i możesz z nim zrobić, co chcesz.
(Źródło: 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

Zauważ, że działa to tylko w przypadku tablic jednowymiarowych (zwanych „normalnymi”?). (Jest to działa tablica wielowymiarowa QuickSort tutaj ).

Jorge Ferreira
źródło
2
Jest to nieco szybsza implementacja w przypadku duplikatów. Prawdopodobnie ze względu na \ 2. Dobra odpowiedź :)
Mark Nold
Wielkie dzięki za to! Używałem sortowania przez wstawianie na zestawie danych zawierającym 2500 wpisów, a prawidłowe sortowanie zajęłoby około 22 sekund. Teraz robi to w ciągu sekundy, to cud! ;)
djule5
Efektem tej funkcji wydaje się być zawsze przenoszenie pierwszego elementu ze źródła na ostatnią pozycję w miejscu docelowym i porządne sortowanie pozostałej części tablicy.
Jasmine
Nadal fajne rozwiązanie 9+ lat później. Ale niestety strona allexperts.com, do której się odwołuje, już nie istnieje ...
Egalth
2
@Egalth - zaktualizowałem pytanie o informacje, które znajdowały się w oryginalnym źródle
ashleedawg
16

Przekonwertowałem algorytm „szybkiego szybkiego sortowania” na VBA, jeśli ktoś inny tego chce.

Mam go zoptymalizowanego do działania na tablicy Int / Longs, ale powinno być proste przekonwertowanie go na taki, który działa na dowolnych porównywalnych elementach.

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
Alain
źródło
Nawiasem mówiąc, były to komentarze do algorytmu: autor James Gosling i Kevin A. Smith rozszerzył o TriMedian i InsertionSort Denisa Ahrensa, ze wszystkimi wskazówkami Roberta Sedgewicka. Wykorzystuje TriMedian i InsertionSort do list krótszych niż 4. To jest ogólna wersja algorytmu szybkiego sortowania CAR Hoare'a. Spowoduje to obsługę tablic, które są już posortowane, oraz tablic ze zduplikowanymi kluczami.
Alain
19
Dzięki Bogu, że to opublikowałem. 3 godziny później rozbiłem się i straciłem dzień pracy, ale przynajmniej jestem w stanie to odzyskać. Teraz to Karma działa. Komputery są trudne.
Alain,
11

Wyjaśnienie w języku niemieckim, ale kod jest dobrze przetestowaną implementacją w miejscu:

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

Wywołane w ten sposób:

Call QuickSort(MyArray, LBound(MyArray), UBound(MyArray))
Konrad Rudolph
źródło
1
Otrzymuję błąd dotyczący ByVal Field () i muszę użyć domyślnego ByRef.
Mark Nold
@MarkNold - yup me too
Richard H
i tak jest to byref, ponieważ byval nie pozwoliłoby na zmianę + zapisywanie wartości Field. Jeśli absolutnie potrzebujesz byval w przekazywanym argumencie, użyj variant zamiast string i no brakets ().
Patrick Lepelletier
@Patrick Tak, tak naprawdę nie mam pojęcia, jak ByValsię tam dostałem. Nieporozumienie prawdopodobnie wynikało z faktu, że w VB.NET ByValbędzie działać tutaj (choć i tak byłoby to zaimplementowane inaczej w VB.NET).
Konrad Rudolph
11
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
Prasand Kumar
źródło
Czy możesz przekonwertować to na funkcję i pokazać przykładowe dane wyjściowe? Jakieś pomysły na temat prędkości?
not2qubit
2
@Ans odrzucił twoją edycję - usunąłeś wszystkie komentarze dotyczące konwersji, więc został tylko niekomentowany kod (jako funkcja). Krótkość jest przyjemna, ale nie zmniejsza „zrozumiałości” dla innych czytelników tej odpowiedzi.
Patrick Artner
@Patrick Artner Kod jest bardzo prosty, szczególnie w porównaniu z innymi przykładami zamieszczonymi tutaj. Myślę, że gdyby ktoś szukał tutaj najprostszego przykładu, to byłby w stanie szybciej znaleźć ten, gdyby zostawił tylko odpowiedni kod.
Ans
Byłaby to świetna odpowiedź, ale prawdopodobnie będziesz musiał poradzić sobie z problemem, który System.Collections.ArrayListznajduje się w różnych lokalizacjach w 32-bitowym i 64-bitowym systemie Windows. Mój 32-bitowy Excel niejawnie próbuje go znaleźć w miejscu, w którym 32-bitowy Win mógłby go przechowywać, ale ponieważ mam 64-bitowy Win, mam również problem: / Otrzymuję błąd -2146232576 (80131700).
ZygD
Dzięki Prasand! Sprytna alternatywa dla innych podejść brutalnej siły.
pstraton
7

Szybkie sortowanie liczb naturalnych (ciągi)

Tylko po to, żeby wbić się w temat. Zwykle, jeśli sortujesz ciągi liczbowe, otrzymasz coś takiego:

    Text1
    Text10
    Text100
    Text11
    Text2
    Text20

Ale naprawdę chcesz, aby rozpoznawał wartości liczbowe i był sortowany jak

    Text1
    Text2
    Text10
    Text11
    Text20
    Text100

Oto jak to zrobić ...

Uwaga:

  • Dawno temu ukradłem z internetu Quick Sort, nie wiem gdzie teraz ...
  • Przetłumaczyłem również z internetu funkcję CompareNaturalNum, która została pierwotnie napisana w języku C.
  • Różnica w stosunku do innych Q-Sorts: nie zamieniam wartości, jeśli BottomTemp = TopTemp

Szybkie sortowanie liczb naturalnych

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

Porównanie liczb naturalnych (używane w szybkim sortowaniu)

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 (używany w 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
Profex
źródło
Niezłe - podoba mi się sortowanie NaturalNumber - będę musiał dodać to jako opcję
Mark Nold
6

Opublikowałem kod w odpowiedzi na powiązane pytanie na StackOverflow:

Sortowanie tablicy wielowymiarowej w VBA

Przykłady kodu w tym wątku obejmują:

  1. Tablica wektorowa Quicksort;
  2. Wielokolumnowa tablica QuickSort;
  3. BubbleSort.

Zoptymalizowany Quicksort Alaina jest bardzo błyszczący: właśnie wykonałem podstawowy podział i rekurencję, ale powyższy przykład kodu ma funkcję „bramkowania”, która ogranicza zbędne porównania zduplikowanych wartości. Z drugiej strony, koduję dla Excela i jest trochę więcej na drodze kodowania obronnego - ostrzegam, będziesz go potrzebować, jeśli twoja tablica zawiera szkodliwy wariant „Empty ()”, który zepsuje twój While .. Wend operatory porównania i uwięź swój kod w nieskończonej pętli.

Należy pamiętać, że algorytmy szybkiego sortowania - i każdy algorytm rekurencyjny - mogą wypełnić stos i spowodować awarię programu Excel. Jeśli twoja tablica ma mniej niż 1024 członków, użyłbym podstawowego narzędzia BubbleSort.

Public Sub QuickSortArray (ByRef SortArray As Variant, _
                                Opcjonalny lngMin As Long = -1, _ 
                                Opcjonalny lngMax As Long = -1, _ 
                                Opcjonalna kolumna lngColumn As Long = 0)
Po błędzie Wznów dalej 
'Sortuj tablicę dwuwymiarową
`` Przykładowe użycie: sortuj arrData według zawartości kolumny 3 ' 'QuickSortArray arrData,,, 3
' „Wysłane przez Jim Rech 20/10/98 Excel.Programming
” Modyfikacje, Nigel Heffernan:
'' Escape nie powiodło się porównanie z pustym wariantem '' Kodowanie obronne: sprawdź wejścia
Dim i As Long Dim j As Long Dim varMid As Variant Dim arrRowTemp jako wariant Dim lngColTemp As Long

Jeśli IsEmpty (SortArray) Then Wyjdź z Sub Koniec, jeśli
Jeśli InStr (TypeName (SortArray), "()") <1 To „IsArray () jest nieco uszkodzony: poszukaj nawiasów w nazwie typu Wyjdź z Sub Koniec, jeśli
Jeśli lngMin = -1 Wtedy lngMin = LBound (SortArray, 1) Koniec, jeśli
Jeśli lngMax = -1 Wtedy lngMax = UBound (SortArray, 1) Koniec, jeśli
If lngMin> = lngMax Then 'nie jest wymagane sortowanie Wyjdź z Sub Koniec, jeśli

i = lngMin j = lngMax
varMid = pusty varMid = SortArray ((lngMin + lngMax) \ 2, lngColumn)
„Wysyłamy„ Puste ”i nieprawidłowe pozycje danych na koniec listy: If IsObject (varMid) Then '' zauważ, że nie sprawdzamy isObject (SortArray (n)) - varMid może wybrać prawidłowy domyślny element członkowski lub właściwość i = lngMax j = lngMin ElseIf IsEmpty (varMid) Następnie i = lngMax j = lngMin ElseIf IsNull (varMid) Następnie i = lngMax j = lngMin ElseIf varMid = "" Następnie i = lngMax j = lngMin ElseIf varType (varMid) = vbError Then i = lngMax j = lngMin ElseIf varType (varMid)> 17 Następnie i = lngMax j = lngMin End If

While i <= j
Podczas gdy SortArray (i, lngColumn) <varMid And i <lngMax i = i + 1 Wend
Podczas gdy varMid <SortArray (j, lngColumn) And j> lngMin j = j - 1 Wend

If i <= j Then
'Zamień rzędy ReDim arrRowTemp (LBound (SortArray, 2) To UBound (SortArray, 2)) Dla lngColTemp = LBound (SortArray, 2) To UBound (SortArray, 2) arrRowTemp (lngColTemp) = SortArray (i, lngColTemp) SortArray (i, lngColTemp) = SortArray (j, lngColTemp) SortArray (j, lngColTemp) = arrRowTemp (lngColTemp) Dalej lngColTemp Usuń 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

Nigel Heffernan
źródło
2

Nie chciałeś rozwiązania opartego na Excelu, ale ponieważ miałem dziś ten sam problem i chciałem przetestować za pomocą innych funkcji aplikacji Office, napisałem funkcję poniżej.

Ograniczenia:

  • Tablice dwuwymiarowe;
  • maksymalnie 3 kolumny jako klucze sortowania;
  • zależy od programu Excel;

Przetestowano wywoływanie programu Excel 2010 z programu Visio 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

Oto przykład, jak przetestować tę funkcję:

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

Jeśli ktoś przetestuje to przy użyciu innych wersji pakietu Office, napisz tutaj, jeśli wystąpią jakiekolwiek problemy.

lucas0x7B
źródło
1
Zapomniałem wspomnieć, że msgbox_array()jest to funkcja przydatna do szybkiego sprawdzania dowolnej dwuwymiarowej tablicy podczas debugowania.
lucas0x7B
1

Zastanawiam się, co byś powiedział o tym kodzie sortowania tablic. Jest szybki do wdrożenia i spełnia swoje zadanie ... nie testowano jeszcze dużych tablic. Działa w przypadku tablic jednowymiarowych, dla wielowymiarowych dodatkowych wartości macierz ponownej lokalizacji musiałaby zostać utworzona (z jednym wymiarem mniej niż tablica początkowa).

       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
Jarek
źródło
5
To jest sortowanie bąbelkowe. OP poprosił o coś innego niż bańka.
Michiel van der Blonk
0

Myślę, że mój kod (przetestowany) jest bardziej „wykształcony”, zakładając, że im prostszy, tym lepszy .

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
Moreno
źródło
3
Co to za rodzaj? A dlaczego mówisz, że jest „wykształcony”?
not2qubit
Po odczytaniu kodu wydaje się, że „sortuje” całą dwuwymiarową tablicę (pobraną z arkusza Excela) na całą tablicę (nie na jakimś konkretnym wymiarze). Zatem wartości zmienią swoje indeksy wymiarowe. A następnie wynik jest odkładany z powrotem na arkusz.
ZygD
1
Chociaż kod może działać w prostych przypadkach, istnieje wiele problemów z tym kodem. Pierwszą rzeczą, którą zauważyłem, jest użycie Doublezamiast Longwszędzie. Po drugie, nie bierze pod uwagę, czy zakres obejmuje wiele obszarów. Sortowanie prostokąta nie wydaje się przydatne i oczywiście nie jest to, o co prosił OP (konkretnie powiedział, że nie ma natywnych rozwiązań Excel / .Net). Ponadto, jeśli porównasz prostsze, lepsze jest bardziej „wyedukowane”, to czy użycie wbudowanej Range.Sort()funkcji nie byłoby najlepsze?
Profex
0

To jest to, czego używam do sortowania w pamięci - można go łatwo rozszerzyć, aby posortować tablicę.

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
Reged
źródło
0

Implementacja Heapsort . O (n log (n)) (zarówno średni, jak i najgorszy przypadek), niestabilny algorytm sortowania.

Używaj z:, Call HeapSort(A)gdzie Ajest jednowymiarową tablicą wariantów, z 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

źródło
0

@Prasand Kumar, oto kompletna procedura sortowania oparta na koncepcjach Prasanda:

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: /programming/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
pstraton
źródło
0

Nieco powiązane, ale szukałem również natywnego rozwiązania VBA w programie Excel, ponieważ zaawansowane struktury danych (słowniki itp.) Nie działają w moim środowisku. Następujące implementuje sortowanie poprzez drzewo binarne w VBA:

  • Zakłada, że ​​tablica jest zapełniana jeden po drugim
  • Usuwa duplikaty
  • Zwraca oddzielony ciąg ( "0|2|3|4|9"), który można następnie podzielić.

Użyłem go do zwrócenia surowego posortowanego wyliczenia wierszy wybranych dla arbitralnie wybranego zakresu

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(),"|")
q335r49
źródło