VBA-Array-Sortierfunktion?

82

Ich suche nach einer anständigen Sortierimplementierung für Arrays in VBA. Ein Quicksort wäre vorzuziehen. Oder ein anderer Sortieralgorithmus als Bubble oder Merge würde ausreichen.

Bitte beachten Sie, dass dies mit MS Project 2003 funktioniert. Vermeiden Sie daher alle nativen Excel-Funktionen und alles, was mit .net zu tun hat.

arrays sorting vba vb6 ms-project Mark Nold
quelle
3
Könnte
MjrKusanagi
Warum magst du Merge Sort nicht?
JWG

Antworten:

99

Schauen Sie hier :
Bearbeiten: Die referenzierte Quelle (allexperts.com) wurde inzwischen geschlossen, aber hier sind die relevanten Autorenkommentare :

Im Web stehen viele Algorithmen zum Sortieren zur Verfügung. Der vielseitigste und normalerweise schnellste ist der Quicksort-Algorithmus . Unten ist eine Funktion dafür.

Rufen Sie es einfach auf, indem Sie ein Array von Werten (Zeichenfolge oder numerisch; es spielt keine Rolle) mit der unteren Array-Grenze (normalerweise 0) und der oberen Array-Grenze (dh UBound(myArray)) übergeben.

Beispiel :Call QuickSort(myArray, 0, UBound(myArray))

Wenn es fertig ist, myArraywird sortiert und Sie können damit machen, was Sie wollen.
(Quelle: 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

Beachten Sie, dass dies nur mit eindimensionalen (auch "normalen"?) Arrays funktioniert . (Es gibt eine Arbeits mehrdimensionales Array QuickSort hier .)

Jorge Ferreira
quelle
2
Dies ist die etwas schnellere Implementierung beim Umgang mit Duplikaten. Wahrscheinlich aufgrund der \ 2. Gute Antwort :)
Mark Nold
Vielen Dank dafür! Ich habe eine Einfügesortierung für einen Datensatz mit 2500 Einträgen verwendet, und es würde ungefähr 22 Sekunden dauern, bis die Sortierung ordnungsgemäß durchgeführt wurde. Jetzt macht es es in einer Sekunde, es ist ein Wunder! ;)
djule5
Der Effekt dieser Funktion scheint immer darin zu bestehen, das erste Element von der Quelle an die letzte Position im Ziel zu verschieben und den Rest des Arrays gut zu sortieren.
Jasmine
9+ Jahre später immer noch eine schöne Lösung. Aber leider existiert die referenzierte Seite allexperts.com nicht mehr ...
Egalth
2
@Egalth - Ich habe die Frage mit den Informationen aktualisiert, die auf der ursprünglichen Quelle waren
ashleedawg
16

Ich habe den Algorithmus 'Fast Quick Sort' in VBA konvertiert, wenn es jemand anderes möchte.

Ich habe es für die Ausführung auf einem Array von Int / Longs optimiert, aber es sollte einfach sein, es in ein Array zu konvertieren, das mit beliebigen vergleichbaren Elementen funktioniert.

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
quelle
Dies waren übrigens die Kommentare für den Algorithmus: Autor James Gosling & Kevin A. Smith erweitert mit TriMedian und InsertionSort von Denis Ahrens, mit allen Tipps von Robert Sedgewick. Es verwendet TriMedian und InsertionSort für Listen, die kürzer als 4 sind generische Version des Quick Sort-Algorithmus von CAR Hoare. Dies behandelt Arrays, die bereits sortiert sind, und Arrays mit doppelten Schlüsseln.
Alain
17
Gott sei Dank habe ich das gepostet. 3 Stunden später stürzte ich ab und verlor meine tägliche Arbeit, kann dies aber zumindest wieder herstellen. Das ist Karma bei der Arbeit. Computer sind schwer.
Alain
11

Erklärung auf Deutsch, aber der Code ist eine gut getestete In-Place-Implementierung:

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

So aufgerufen:

Call QuickSort(MyArray, LBound(MyArray), UBound(MyArray))
Konrad Rudolph
quelle
1
Ich erhalte eine Fehlermeldung für ByVal Field () und muss das Standard-ByRef verwenden.
Mark Nold
@ MarkNold - yup ich auch
Richard H
Es ist sowieso byref, weil byval das Ändern + Speichern von Feldwerten nicht zulässt. Wenn Sie in einem übergebenen Argument unbedingt ein Byval benötigen, verwenden Sie eine Variante anstelle von string und no brakets ().
Patrick Lepelletier
@Patrick Ja, ich habe keine Ahnung, wie die ByValda reingekommen sind . Die Verwirrung kam wahrscheinlich von der Tatsache, dass in VB.NET ByValhier funktionieren würde (obwohl dies in VB.NET sowieso anders implementiert wäre).
Konrad Rudolph
9 
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
quelle
Können Sie dies in eine Funktion konvertieren und eine Beispielausgabe anzeigen? Irgendwelche Ideen zur Geschwindigkeit?
not2qubit
2
@Ans lehnte Ihre Bearbeitung ab - Sie haben alle Kommentare zu Ihrer Konvertierung entfernt, sodass nur noch nicht kommentierter Code (als Funktion) übrig blieb. Kürze ist nett, aber nicht, wenn die "Verständlichkeit" für andere Leser dieser Antwort verringert wird.
Patrick Artner
@Patrick Artner Der Code ist sehr einfach, insbesondere im Vergleich zu anderen hier veröffentlichten Beispielen. Ich würde denken, wenn jemand hier nach dem einfachsten Beispiel suchen würde, könnte er dieses schneller finden, wenn nur der relevante Code übrig wäre.
Ans
Wäre eine gute Antwort, aber Sie müssen sich wahrscheinlich mit einem Problem befassen, System.Collections.ArrayListdas sich an verschiedenen Orten in 32-Bit- und 64-Bit-Windows befindet. Mein 32-Bit-Excel versucht implizit, es an einem Ort zu finden, an dem 32-Bit-Win es speichern würde, aber da ich 64-Bit-Win habe, habe ich auch ein Problem: / Ich erhalte eine Fehlermeldung -2146232576 (80131700).
ZygD
Danke Prasand! Eine clevere Alternative zu den anderen Brute-Force-Ansätzen.
Pstraton
7

Natürliche Zahl (Strings) Schnelle Sortierung

Nur um sich auf das Thema zu konzentrieren. Wenn Sie Zeichenfolgen mit Zahlen sortieren, erhalten Sie normalerweise Folgendes:

    Text1
    Text10
    Text100
    Text11
    Text2
    Text20

Aber Sie möchten wirklich, dass es die numerischen Werte erkennt und wie sortiert wird 

    Text1
    Text2
    Text10
    Text11
    Text20
    Text100

So geht's ...

Hinweis:

  • Ich habe die Schnellsortierung vor langer Zeit aus dem Internet gestohlen, nicht sicher, wo jetzt ...
  • Ich habe die CompareNaturalNum-Funktion, die ursprünglich in C geschrieben wurde, auch aus dem Internet übersetzt.
  • Unterschied zu anderen Q-Sorts: Ich tausche die Werte nicht aus, wenn BottomTemp = TopTemp

Schnelle Sortierung der natürlichen Zahl

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

Natürlicher Zahlenvergleich (wird beim schnellen Sortieren verwendet)

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 (wird in CompareNaturalNum verwendet)

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
quelle
Nizza - ich mag die NaturalNumber-Sorte - muss dies als Option hinzufügen
Mark Nold
6

Ich habe einen Code als Antwort auf eine verwandte Frage zu StackOverflow gepostet:

Sortieren eines mehrdimensionalen Arrays in VBA

Die Codebeispiele in diesem Thread umfassen:

  1. Ein Vektorarray Quicksort;
  2. Ein mehrspaltiges Array QuickSort;
  3. Ein BubbleSort.

Alains optimiertes Quicksort ist sehr glänzend: Ich habe gerade ein grundlegendes Split-and-Recurse durchgeführt, aber das obige Codebeispiel verfügt über eine 'Gating'-Funktion, die redundante Vergleiche von doppelten Werten reduziert. Auf der anderen Seite codiere ich für Excel, und es gibt ein bisschen mehr Möglichkeiten für die defensive Codierung - seien Sie gewarnt, Sie werden es brauchen, wenn Ihr Array die schädliche Variante 'Empty ()' enthält, die Ihre While-Funktion unterbricht. Wend Vergleichsoperatoren und fangen Sie Ihren Code in einer Endlosschleife.

Beachten Sie, dass Quicksort-Algorithmen - und jeder rekursive Algorithmus - den Stapel füllen und Excel zum Absturz bringen können. Wenn Ihr Array weniger als 1024 Mitglieder hat, würde ich eine rudimentäre BubbleSort verwenden.

Public Sub QuickSortArray (ByRef SortArray als Variante, _
                                Optional lngMin As Long = -1, _ 
                                Optional lngMax As Long = -1, _ 
                                Optionale lngColumn As Long = 0)
On Error Resume Next 

'Sortieren Sie ein zweidimensionales Array

'Beispielverwendung: Sortieren Sie arrData nach dem Inhalt von Spalte 3
'
'QuickSortArray arrData ,,, 3

'
'Gepostet von Jim Rech 20.10.98 Excel.Programming 

' Modifikationen, Nigel Heffernan:

'' Vergleich fehlgeschlagener Vergleich mit leerer Variante
'' Defensive Codierung: Eingaben prüfen

Dim ich so lange
Dim j So lange
Dim varMid As Variant
Dim arrRowTemp As Variant
Dim lngColTemp As Long


 Wenn IsEmpty (SortArray) Dann
     Sub beenden
 End If

 Wenn InStr (TypeName (SortArray), "()") <1 ist, ist 'IsArray () etwas kaputt: Suchen Sie im Typnamen nach Klammern
     Sub beenden
 End If

 Wenn lngMin = -1, dann
     lngMin = LBound (SortArray, 1)
 End If
 
 Wenn lngMax = -1 Dann
     lngMax = UBound (SortArray, 1)
 End If
 
 Wenn lngMin> = lngMax, dann ist keine Sortierung erforderlich
     Sub beenden
 End If


 i = lngMin
 j = lngMax

 varMid = Leer
 varMid = SortArray ((lngMin + lngMax) \ 2, lngColumn)

 'Wir senden' leere 'und ungültige Datenelemente an das Ende der Liste:
 Wenn IsObject (varMid) Dann 'beachten Sie, dass wir isObject (SortArray (n)) nicht überprüfen - varMid übernimmt möglicherweise ein gültiges Standardmitglied oder eine gültige Standardeigenschaft
     i = lngMax
     j = lngMin
 ElseIf IsEmpty (varMid) Dann
     i = lngMax
     j = lngMin
 ElseIf IsNull (varMid) Dann
     i = lngMax
     j = lngMin
 ElseIf varMid = "" Dann
     i = lngMax
     j = lngMin
 ElseIf varType (varMid) = vbError Dann
     i = lngMax
     j = lngMin
 ElseIf varType (varMid)> 17 Dann
     i = lngMax
     j = lngMin
 End If 


 While i <= j

     Während SortArray (i, lngColumn) <varMid und i <lngMax
         i = i + 1
     Wend

     Während varMid <SortArray (j, lngColumn) und j> lngMin
         j = j - 1
     Wend 


     Wenn i <= j Dann

         'Tauschen Sie die Reihen
         ReDim arrRowTemp (LBound (SortArray, 2) To UBound (SortArray, 2))
         Für lngColTemp = LBound (SortArray, 2) To UBound (SortArray, 2)
             arrRowTemp (lngColTemp) = SortArray (i, lngColTemp)
             SortArray (i, lngColTemp) = SortArray (j, lngColTemp)
             SortArray (j, lngColTemp) = arrRowTemp (lngColTemp)
         Weiter lngColTemp
         Löschen Sie arrRowTemp

         i = i + 1
         j = j - 1 

     End If 


 Wend

 Wenn (lngMin <j), rufen Sie QuickSortArray auf (SortArray, lngMin, j, lngColumn)
 If (i <lngMax) Rufen Sie QuickSortArray (SortArray, i, lngMax, lngColumn) 

 
End Sub auf

Nigel Heffernan
quelle
2

Sie wollten keine Excel-basierte Lösung, aber da ich heute das gleiche Problem hatte und mit anderen Office-Anwendungsfunktionen testen wollte, habe ich die folgende Funktion geschrieben.

Einschränkungen:

  • 2-dimensionale Arrays;
  • maximal 3 Spalten als Sortierschlüssel;
  • hängt von Excel ab;

Der Aufruf von Excel 2010 aus Visio 2010 wurde getestet

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

Dies ist ein Beispiel zum Testen der Funktion:

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

Wenn jemand dies mit anderen Office-Versionen testet, posten Sie bitte hier, wenn es Probleme gibt.

lucas0x7B
quelle
1
Ich habe vergessen zu erwähnen, dass dies msgbox_array()eine Funktion ist, mit der sich zweidimensionale Arrays beim Debuggen schnell untersuchen lassen.
lucas0x7B
1

Ich frage mich, was Sie zu diesem Array-Sortiercode sagen würden. Es ist schnell zu implementieren und erledigt den Job ... noch nicht auf große Arrays getestet. Es funktioniert für eindimensionale Arrays, für mehrdimensionale zusätzliche Werte müsste eine Umlagerungsmatrix erstellt werden (mit einer Dimension weniger als das ursprüngliche Array).

       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
quelle
5
Das ist Blasensortierung. Das OP bat um etwas anderes als Blase.
Michiel van der Blonk
0

Ich denke, mein Code (getestet) ist "gebildeter", vorausgesetzt, je einfacher, desto besser .

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
quelle
3
Was ist das für eine Art? Und warum sagst du, es ist "gebildet"?
not2qubit
Aus dem Lesen des Codes geht hervor, dass das gesamte zweidimensionale Array (aus einer Excel-Tabelle entnommen) nach dem gesamten Array (nicht nach einer bestimmten Dimension) "sortiert" wird. Werte ändern also ihre Dimensionsindizes. Und dann wird das Ergebnis wieder auf das Blatt gelegt.
ZygD
1
Während der Code in einfachen Fällen funktionieren kann, gibt es viele Probleme mit diesem Code. Das erste, was mir auffällt, ist die Verwendung von Doublestatt Longüberall. Zweitens wird nicht berücksichtigt, ob der Bereich mehrere Bereiche umfasst. Das Sortieren eines Rechtecks ​​scheint nicht sinnvoll zu sein und ist natürlich nicht das, wonach das OP gefragt hat (insbesondere keine nativen Excel / .Net-Lösungen). Wenn Sie gleichsetzen, je einfacher, desto besser ist "gebildeter", wäre es dann nicht am Range.Sort()besten , die eingebaute Funktion zu verwenden?
Profex
0

Dies ist, was ich zum Sortieren im Speicher verwende - es kann leicht erweitert werden, um ein Array zu sortieren.

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
quelle
0

Heapsort- Implementierung. Ein instabiler O (n log (n)) (sowohl durchschnittlicher als auch schlechtester Fall), instabiler Sortieralgorithmus.

Verwendung mit : Call HeapSort(A), wobei Aein eindimensionales Array von Varianten ist, mit 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

quelle
0

@Prasand Kumar, hier ist eine vollständige Sortierroutine, die auf Prasands Konzepten basiert:

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
quelle
0

Etwas verwandt, aber ich suchte auch nach einer nativen Excel-VBA-Lösung, da erweiterte Datenstrukturen (Wörterbücher usw.) in meiner Umgebung nicht funktionieren. Im Folgenden wird die Sortierung über einen Binärbaum in VBA implementiert:

  • Angenommen, das Array wird einzeln gefüllt
  • Entfernt Duplikate
  • Gibt eine getrennte Zeichenfolge ( "0|2|3|4|9") zurück, die dann geteilt werden kann.

Ich habe es verwendet, um eine rohe sortierte Aufzählung von Zeilen zurückzugeben, die für einen willkürlich ausgewählten Bereich ausgewählt wurden

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
quelle