VBA-array sorteerfunctie?

Ik ben op zoek naar een fatsoenlijke sorteerimplementatie voor arrays in VBA. Een Quicksort zou de voorkeur hebben. Of een andere sorteeralgoritmeanders dan bubble of merge zou voldoende zijn.

Houd er rekening mee dat dit is bedoeld om te werken met MS Project 2003, dus vermijd alle native Excel-functies en alles wat met .net te maken heeft.

Antwoord 1, autoriteit 100%

Kijk hier:
Bewerken:de bron waarnaar wordt verwezen (allexperts.com) is sindsdien gesloten, maar hier zijn de relevante auteuropmerkingen:

Er zijn veel algoritmen beschikbaar op internet om te sorteren. De meest veelzijdige en meestal de snelste is het Quicksort-algoritme. Hieronder staat een functie ervoor.

Noem het eenvoudig door een reeks waarden door te geven (tekenreeks of numeriek; het maakt niet uit) met de Lower Array Boundary(meestal 0) en de Upper Array Boundary(dwz UBound(myArray).)

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

Als het klaar is, wordt myArraygesorteerd en kun je ermee doen wat je wilt.
_{(Bron: 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

Merk op dat dit alleen werkt met eendimensionale(ook wel “normale”?) arrays genoemd. (Er is hiereen werkende multidimensionale array QuickSort.)

Antwoord 2, autoriteit 17%

Ik heb het ‘fast quick sort’-algoritme geconverteerd naar VBA, als iemand anders het wil.

Ik heb het geoptimaliseerd om op een array van Int/Longs te draaien, maar het zou eenvoudig moeten zijn om het te converteren naar een array die werkt op willekeurig vergelijkbare elementen.

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

Antwoord 3, Autoriteit 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

Antwoord 4, Autoriteit 11%

Uitleg in het Duits, maar de code is een goed getest in de plaats Implementatie:

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

Opgeroepen als volgt:

Call QuickSort(MyArray, LBound(MyArray), UBound(MyArray))

Antwoord 5, Autoriteit 6%

Natural Number (strings) Snel sorteren

Gewoon om op het onderwerp te stapelen.
Normaal gesproken, als je snaren met cijfers sorteert, krijg je zoiets als dit:

   Text1
    Text10
    Text100
    Text11
    Text2
    Text20

Maar je wilt echt het herkennen van de numerieke waarden en wordt gesorteerd als

   Text1
    Text2
    Text10
    Text11
    Text20
    Text100

Hier is hoe het te doen …

Opmerking:

• Ik heb de snelle sorteer van het internet lang geleden gestolen, niet zeker waar nu …
• Ik heb de vergelijkende functie die ook in C van het internet van internet werd geschreven.
• Verschil met andere Q-Sorts: ik wissel de waarden niet om als de BottomTemp = TopTemp

Natuurlijk nummer snel sorteren

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

Natuurlijke getallen vergelijken (gebruikt bij snel sorteren)

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 (gebruikt in vergelijkenaturalnum)

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

Antwoord 6, Autoriteit 5%

Ik heb een code gepost in antwoord op een gerelateerde vraag over Stackoverflow:

Een multidimensionale array sorteren in VBA

De codevoorbeelden in die thread omvatten:

1. Een vectorarray Quicksort;
2. Een array met meerdere kolommen QuickSort;
3. Een BubbleSort.

Alain’s geoptimaliseerde Quicksort is erg glimmend: ik heb zojuist een eenvoudige split-and-recurse gedaan, maar het bovenstaande codevoorbeeld heeft een ‘gating’-functie die overbodige vergelijkingen van dubbele waarden vermindert. Aan de andere kant codeer ik voor Excel, en er is iets meer in de weg van defensieve codering – wees gewaarschuwd, je hebt het nodig als je array de verderfelijke ‘Empty()’-variant bevat, die je While zal breken. Gebruik vergelijkingsoperatoren en sluit uw code in een oneindige lus.

Houd er rekening mee dat quicksort-algoritmen – en elk recursief algoritme – de stapel kunnen vullen en Excel kunnen laten crashen. Als je array minder dan 1024 leden heeft, zou ik een rudimentaire BubbleSort gebruiken.

Public Sub QuickSortArray(ByRef SortArray As Variant, _
                Optioneel lngMin As Long = -1, _
                Optioneel lngMax As Long = -1, _
                Optionele lngColumn As Long = 0)
Bij fout Hervatten Volgende

'Sorteer een 2-dimensionale array

' Voorbeeldgebruik: sorteer arrData op de inhoud van kolom 3
'
' QuickSortArray arrData, , , 3

'
'Geplaatst door Jim Rech 10/20/98 Excel.Programmeren

'Modificaties, Nigel Heffernan:

' ' Escape mislukte vergelijking met lege variant
' ' Defensieve codering: controleer invoer

Dim ik zo lang
Dim j zo lang
Dim varMid As Variant
Dim arrRowTemp As Variant
Dim lngColTemp zo lang


 Als Is Leeg (SortArray) Dan
   Sluit sub
 Einde als

Als INST (TIMENAME (SORTARRAY), "()") & LT; 1 Dan is 'isarray () enigszins kapot: kijk naar beugels in de naam van het type
   EXIT SUB
 Einde als
 Als LNGMIN = -1 dan
   lngmin = lbound (sortarray, 1)
 Einde als
 Als LNGMAX = -1 dan
   LNGMAX = UBound (Sortarray, 1)
 Einde als
 Als LGMIN & GT; = LNGMAX dan 'geen sortering vereist
   EXIT SUB
 Einde als 


 i = lngmin
 j = lngmax 

 varmid = leeg
 varmid = sortarray ((lngmin + lngmax) \ 2, lngcolumn) 

 'We sturen' lege 'en ongeldige gegevensitems naar het einde van de lijst:
 Als Isobject (Varmid) dan 'Merk op dat we deObject niet controleren (Sortarray (N)) - Varmid kan een geldig standaardorgaan of eigendom ophalen
   i = lngmax
   j = lngmin
 Elsef is duidelijk (varmid)
   i = lngmax
   j = lngmin
 Andere is dannull (varmid) dan
   i = lngmax
   j = lngmin
 Manyif Varmid = "" dan
   i = lngmax
   j = lngmin
 Elsef VARTYPE (VARMID) = VBERROR DAN
   i = lngmax
   j = lngmin
 ElseF VARTYPE (Varmid) & GT; 17 dan
   i = lngmax
   j = lngmin
 Einde als 


 Terwijl I & LT; = J 

   Terwijl Sortarray (I, LNGColumn) & LT; Varmid en I & LT; lngmax
     i = i + 1
   Wendig
   Terwijl Varmid & Lt; Sortarray (J, LNGColumn) en J & GT; lngmin
     j = j - 1
   Wend 


   Als I & LT; = J dan 

     'Wissel de rijen
     Redim Arrrowtemp (LBound (Sortarray, 2) naar Ubound (Sortarray, 2))
     Voor LNGCOLTEMP = LBound (Sortarray, 2) naar Ubound (Sortarray, 2)
       Arrrowtemp (lngcoltemp) = Sortarray (I, LNGColtemp)
       Sortarray (I, LNGColtemp) = Sortarray (J, LNGColtemp)
       Sortarray (J, LNGColtemp) = Arrrowtemp (LNGCOLTEMP)
     Volgende LNGColtemp
     Wissen arrrowtemp 

     i = i + 1
     j = j - 1 

   Einde als 


 Wendig 
 Als (lngMin < j) Roep dan QuickSortArray(SortArray, lngMin, j, lngColumn) aan
 Als (i < lngMax) Roep dan QuickSortArray(SortArray, i, lngMax, lngColumn) aan


Einde sub

Antwoord 7, autoriteit 2%

Ik vraag me af wat u zou zeggen over deze sorteercode voor arrays. Het is snel voor implementatie en doet het werk … nog niet getest voor grote arrays. Het werkt voor eendimensionale arrays, voor multidimensionale aanvullende waarden zou een herlocatiematrix moeten worden gebouwd (met één dimensie minder dan de initiële 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

Antwoord 8, autoriteit 2%

U wilde geen op Excel gebaseerde oplossing, maar aangezien ik vandaag hetzelfde probleem had en wilde testen met andere Office Applications-functies, heb ik de onderstaande functie geschreven.

Beperkingen:

• 2-dimensionale arrays;
• maximaal 3 kolommen als sorteersleutels;
• afhankelijk van Excel;

Getest met aanroepen van Excel 2010 vanuit 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

Dit is een voorbeeld van het testen van de functie:

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

Als iemand dit test met andere versies van Office, plaats hier als er problemen zijn.

Antwoord 9

Ik denk dat mijn code (getest) meer “opgeleid” is, ervan uitgaande dat hoe eenvoudiger, hoe beter.

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

Antwoord 10

Dit is wat ik gebruik om in het geheugen te sorteren – het kan gemakkelijk worden uitgebreid om een array te sorteren.

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

Antwoord 11

HealthSort implementatie. Een O (n log (n)) (zowel gemiddeld als slecht), op zijn plaats, onstabiel Algoritme sorteren.

Gebruik met: Call HeapSort(A), waarbij Aeen eendimensionale reeks van varianten is, met 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

Antwoord 12

@Pasand Kumar, hier is een complete sorteerroutine op basis van de concepten van Prasand:

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: https://stackoverflow.com/questions/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

Antwoord 13

Enigszins verwant, maar ik was ook op zoek naar een native Excel VBA-oplossing omdat geavanceerde datastructuren (woordenboeken, enz.) niet werken in mijn omgeving. Het volgende implementeert sorteren via een binaire boom in VBA:

• Er wordt aangenomen dat de array één voor één wordt gevuld
• Verwijdert duplicaten
• Retourneert een gescheiden tekenreeks ("0|2|3|4|9") die vervolgens kan worden gesplitst.

Ik heb het gebruikt voor het retourneren van een onbewerkte gesorteerde opsomming van rijen die zijn geselecteerd voor een willekeurig geselecteerd bereik

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(),"|")

Antwoord 14

Referentie VBA ArrayList– System.Collections.ArrayList

Geschikt voor het sorteren van gescheiden items binnen een cel, verschillende cellen in een rij of een kolom (onder voorbehoud van transponeerbeperking – tot 65536 rijen; verder kan deze functie in een subroutine worden gebruikt om te vullen een bereik met gesorteerde waarden).

Voor deze functie hoeft u niet door de items te bladeren. Stel dat er 100 items zijn, dan hebben andere procedures voor het vergelijken van elke waarde met andere items 100 x 100 = 10000 lussen nodig. Dit heeft maximaal 100 x 2 = 200 lussen nodig voor nummer- en tekstitems en 300 voor datums. Dus VBA ArrayListis handig om een groter aantal items te sorteren.

YouTube-video

Option Explicit
'https://excelmacromastery.com/vba-arraylist/
Function SortList(myRng As Range, deLmt As String, Optional ReturnArray = 0, Optional srtCriteria = 0)
'ReturnArray - 0 or none retruns srting, else array
'srtCriteria - 0 or none retruns Ascending, else descending
Dim myString As String, arrLst As Object, i As Long, j As Long, myRngMod As Range
Dim arr1() As String, arr2, newstr As String
myString = ""
Set arrLst = CreateObject("System.Collections.ArrayList")
'Determine number of cells and join cell values
If myRng.Cells.Count = 1 Then
    myString = myRng
    Else
    If myRng.Rows.Count = 1 Then
        myString = Join(Application.Index((myRng.Value), 1, 0), deLmt)
        Else
        If myRng.Rows.Count < 65537 Then
            myString = Join(Application.Index(Application.Transpose(myRng.Value), 1, 0), deLmt)
            Else
            i = myRng.Rows.Count Mod 65536
            Set myRngMod = Range(Cells(myRng.Row, myRng.Column), _
                            Cells(myRng.Rows.Count - i + 1, myRng.Column))
            For j = 1 To myRngMod.Rows.Count Step 65536
                myString = myString & Join(Application.Index(Application.Transpose( _
                        Range(Cells(myRng.Rows(j), myRng.Column), Cells(j + 65536, myRng.Column)).Value), 1, 0), deLmt) & deLmt
            Next
            Set myRngMod = Range(Cells(j + 1, myRng.Column), Cells(myRng.Rows(myRng.Rows.Count).Row, myRng.Column))
            myString = myString & Join(Application.Index(Application.Transpose(myRngMod.Value), 1, 0), deLmt)
        End If
    End If
End If
'Add values to the arraylist
arr1 = Split(myString, deLmt)
For i = 0 To UBound(arr1)
    If IsNumeric(Cells(myRng.Row, myRng.Column)) Then
        If Len(arr1(i)) = 0 Then
        arrLst.Insert i, Val(0)
        Else
        arrLst.Insert i, Val(arr1(i))
        End If
    Else
        If Len(arr1(i)) = 0 Then
        arrLst.Insert i, ""
        Else
            If IsDate(arr1(i)) Then
            j = CLng(DateValue(arr1(i)))
                arrLst.Insert i, WorksheetFunction.Rept("0", 5 - Len(Trim(j))) & _
                        CLng(DateValue(arr1(i))) & "ISDATE" & arr1(i)
            Else
            arrLst.Insert i, arr1(i)
            End If
        End If
    End If
Next
'*************** Sort Arraylist
arrLst.Sort
'Only for dates
For i = 0 To arrLst.Count - 1
    If InStr(1, arrLst(i), "ISDATE", vbBinaryCompare) <> 0 Then
        If myRng.Cells.Count = 1 Then
        arrLst.Insert i, Mid(arrLst(i), 12, Len(arrLst(i)))
        Else
        arrLst.Insert i, DateValue(Mid(arrLst(i), 12, Len(arrLst(i))))
        End If
        arrLst.RemoveAt i + 1
    End If
Next
'Populating array feom the arraylist based on srtCriteria
If srtCriteria = 0 Then
    arr2 = arrLst.toarray
    Else
    arrLst.Reverse '*************** Sorted Arraylist reversed
    arr2 = arrLst.toarray
End If
If ReturnArray = 0 Then
    SortList = Join(arr2, deLmt)
    'This can be used to popoulate single cell with sorted list.
    Else
    If myRng.Rows.Count < 65537 Then
    SortList = Application.Transpose(arr2)
    'This can be used to popoulate range with sorted array.
    Else
    SortList = Join(arr2, deLmt)
    'This can be used in a subroutine to popoulate range with sorted array _
        by looping over at steps of 65536
    End If
End If
End Function