Ein Quicksort auf ein Array. Dabei wird ein zweiter Array mitsortiert

Download udf_multisort.bas (V-1.0.0)

bool = multisort(array-1 [,array-2 [,sortOrder]])

Public Function multiSort( _
        ByRef ioSortArr As Variant, _
        Optional ByRef ioSecArr As Variant = Null, _
        Optional ByVal iSortOder As eSortOrder = sAscending _
) As Boolean

• ioSortArr Dieser Array wird sortiert. Hier darf es sich nicht um Objekte oder Udt handeln!
• ioSecArr Dieser Array wird mitsortiert, paralell zum Ersten
• iSortOder Angabe der Sortierrichtung

True. Bei einem Fehler False. Der Fehler wird im direktfenster ausgegeben

Public Enum eSortOrder
    sAscending = &HA3      '(acCmdSortAscending) Aufsteigend
    sDescending = &HA4     '(acCmdSortDescending) Absteigend
End Enum

Für die Ausgabe der Resultate verwendete ich die Funktion [VBA] print_r()

2 Arrays. Der Erste wird sortiert und der Zweite entsprechend nachgeführt

a = array("a", "d", "b", "c")
b = array(100, 10, 1, 1000)
 
? multiSort(a, b)
True
 
print_r a
<Variant()>  (
    [#0] => <String> 'a'
    [#1] => <String> 'b'
    [#2] => <String> 'c'
    [#3] => <String> 'd'
)
 
print_r b
<Variant()>  (
    [#0] => <Integer> 100
    [#1] => <Integer> 1
    [#2] => <Integer> 1000
    [#3] => <Integer> 10
)

Wieder 2 Arrays, jedoch sind sie verscheiden gross

'Der Erste ist grösser, der Zweite wird soweit mitsortiert wie Einträge vorhanden sind
a = array("a", "d", "b", "c")
b = array(100, 10)

? multiSort(a, b)
True

? join(a, ", ")
a, d, b, c
? join(b, ", ")
100, 10

'Der Zweite ist grösser, Alle Mehreinträge bleiben unsortiert vorhanden
a = array("b", "a")
b = array(100, 10, 99, 1)

? multiSort(a, b)
True

? join(a, ", ")
a, b
? join(b, ", ")
10, 100, 99, 1

Public Sub testMs()
    Dim a() As Variant: ReDim a(1 To 3)
    a(1) = "abc"
    a(2) = Null
    a(3) = 1234
 
    Dim b() As Variant: ReDim b(4 To 7)
    b(4) = "NR. 4"
    b(5) = "NR. 5"
    b(6) = "NR. 6"
    b(7) = "NR. 7"
 
    Debug.Print multiSort(a, b)
 
    Debug.Print "Array a:"
    print_r a
 
    Debug.Print "Array b:"
    print_r b
End Sub

True
Array a:
<Variant()>  (
    [#1] => <Null> 
    [#2] => <Integer> 1234
    [#3] => <String> 'abc'
)
Array b:
<Variant()>  (
    [#4] => <String> 'NR. 5'
    [#5] => <String> 'NR. 6'
    [#6] => <String> 'NR. 4'
    [#7] => <String> 'NR. 7'
)

Wir haben ein Array mit Objekten. Dieses wollen wir nach einer Objekteigenschaft sortieren.
Ich nehme für das Beispiel [VBA] DateTime

    'Beispieldaten
    Dim objList() As Variant:     ReDim objList(2)
    Set objList(0) = DateTime(#1/1/2019#)
    Set objList(1) = DateTime(#5/1/2018#)
    Set objList(2) = DateTime(#3/1/2020#)
 
    'Property dateValue extrahieren.
    Dim sortList() As Variant: ReDim sortList(LBound(objList) To UBound(objList))
    Dim i&: For i = LBound(objList) To UBound(objList)
        sortList(i) = objList(i).dateValue
    Next i
 
    'sortieren
    multiSort sortList, objList
 
    print_r objList

<Variant()>  (
    [#0] => <Class Module::DateTime>  (
        [timeStamp] => <Date> 01.05.2018
        [unixTimeStamp] => <Long> 1525132800
        [dateValue] => <Date> 01.05.2018
        [timeValue] => <Date> 00:00:00
	...
    )
    [#1] => <Class Module::DateTime>  (
        [timeStamp] => <Date> 01.01.2019
        [unixTimeStamp] => <Long> 1546300800
        [dateValue] => <Date> 01.01.2019
        [timeValue] => <Date> 00:00:00
	...
    )
    [#2] => <Class Module::DateTime>  (
        [timeStamp] => <Date> 01.03.2020
        [unixTimeStamp] => <Long> 1583020800
        [dateValue] => <Date> 01.03.2020
        [timeValue] => <Date> 00:00:00
	...
    )
)

Damit kann man auch ein Dictionary sortieren

'/**
' * Sortiert ein Dictionary nach den Einträgen
' * @param  Dictionary
' * @param  eSortOrder
' * @return Dictionary
' */
Public Function sortDictByItems(ByRef ioDict As Object, Optional ByVal iSortOder As eSortOrder = sAscending) As Boolean
On Error GoTo Err_Handler
 
    Dim keys():     keys = ioDict.keys
    Dim items():    items = ioDict.items
    Dim i&
 
    sortDictByItems = multiSort(items, keys)
    If Not sortDictByItems Then Exit Function
 
    Dim dict As Object: Set dict = CreateObject("scripting.Dictionary")
    If iSortOder = sAscending Then
        For i = 0 To UBound(keys)
            dict.add keys(i), items(i)
        Next i
    Else
        For i = UBound(keys) To 0 Step -1
            dict.add keys(i), items(i)
        Next i
    End If
    Set ioDict = dict
 
Exit_Handler:
    Exit Function
Err_Handler:
    Debug.Print "Error in multiQuickSort(): ", Err.Number, Err.Description
    Resume Exit_Handler
    Resume
End Function

Public Sub testDictSort()
    Dim dict As New Dictionary
    dict.add "a", 18974
    dict.add "b", 156
    dict.add "c", 99999
 
    Debug.Print sortDictByItems(dict)
    print_r dict
 
End Sub

True
<Dictionary>  (
    [b] => <Integer> 156
    [a] => <Integer> 18974
    [c] => <Long> 99999
)

Download udf_multisort.bas (V-1.0.0)