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
)

udf_multisort.bas

Attribute VB_Name = "udf_multisort"
'-------------------------------------------------------------------------------
'File         : udf_multisort.bas
'               All rights reserved
'               http://wiki.yaslaw.info/dokuwiki/doku.php/vba
'Environment  : VBA 2010 +
'Version      : 1.0.0
'Name         : multiQuickSort
'Author       : Stefan Erb (ERS)
'History      : 17.10.2019 - ERS - Creation
'-------------------------------------------------------------------------------
 
Option Explicit
 
'/**
' * Sortierrichtung
' */
Public Enum eSortOrder
    sAscending = &HA3      '(acCmdSortAscending) Aufsteigend
    sDescending = &HA4     '(acCmdSortDescending) Absteigend
End Enum
 
 
'/**
' * Sortiert 2 Arrays anhand des ersten
' * @param  Array           Dieser Array wird sortiert. Hier darf es sich nicht um Objekte oder Udt handeln!
' * @param  Array/Null      Dieser Array wird mitsortiert, paralell zum Ersten
' * @param  eSortOrder      Angabe der Sortierrichtung
' * @return Boolean         Information ob die Sortierng erfolgreich war
' */
Public Function multiSort( _
        ByRef ioSortArr As Variant, _
        Optional ByRef ioSecArr As Variant = Null, _
        Optional ByVal iSortOder As eSortOrder = sAscending _
) As Boolean
On Error GoTo Err_Handler
    'Arrays übernhemen, damit im Fehlerfall die Originale unebrührt sind
    Dim arr1:   arr1 = ioSortArr
    Dim arr2:   arr2 = ioSecArr
 
    'Prüfungen
    If Not IsArray(arr1) Then Err.Raise 13     'Type missmacth
    If IsNull(arr2) Then arr2 = arr1
    If Not IsArray(arr2) Then Err.Raise 13      'Type missmacth
 
    'Falls nicht beide mit dem gleichen Index beginnen
    Dim delta&: delta = LBound(arr1) - LBound(arr2)
 
    x__multiQuickSort arr1, arr2, LBound(arr1), least(UBound(arr1), UBound(arr2) + delta), delta
 
    If iSortOder = sAscending Then
        ioSortArr = arr1
        If Not IsNull(ioSecArr) Then ioSecArr = arr2
    Else
        'Sortierung umdrehen
        Dim tmpArr As Variant: ReDim tmpArr(LBound(arr1) To UBound(arr1))
        Dim i&: For i = UBound(arr1) To LBound(arr1) Step -1
            tmpArr(UBound(arr1) - i + LBound(arr1)) = arr1(i)
        Next i
        ioSortArr = tmpArr
 
        If Not IsNull(ioSecArr) Then
            ReDim tmpArr(LBound(arr2) To UBound(arr2))
            For i = UBound(arr2) To LBound(arr2) Step -1
                tmpArr(UBound(arr2) - i + LBound(arr2)) = arr2(i)
            Next i
            ioSecArr = tmpArr
        End If
    End If
    multiSort = True
 
Exit_Handler:
    Exit Function
Err_Handler:
    Debug.Print "Error in multiQuickSort(): ", Err.Number, Err.Description
    Resume Exit_Handler
    Resume
End Function
 
'-------------------------------------------------------------------------------
' -- Private Methodes
'-------------------------------------------------------------------------------
 
'/**
' * Quicksort, dei in eienr Schleife duchtgeht
' * Apassung von https://stackoverflow.com/a/152325, so dass ein 2ter Array mitsortiert wird
' */
Private Sub x__multiQuickSort(ioSortArr As Variant, ioSecArr As Variant, inLow As Long, inHi As Long, Optional iDelta& = 0)
    Dim tmpLow&:    tmpLow = inLow
    Dim tmpHi&:     tmpHi = inHi
    Dim pivot:      pivot = NZ(ioSortArr((inLow + inHi) \ 2))
 
    While (tmpLow <= tmpHi)
       While (NZ(ioSortArr(tmpLow)) < pivot And tmpLow < inHi)
          tmpLow = tmpLow + 1
       Wend
 
       While (pivot < NZ(ioSortArr(tmpHi)) And tmpHi > inLow)
          tmpHi = tmpHi - 1
       Wend
 
       If (tmpLow <= tmpHi) Then
          Dim tmpSwapArr:   tmpSwapArr = ioSortArr(tmpLow)
          Dim tmpSwapSec:   ref tmpSwapSec, ioSecArr(tmpLow - iDelta)
          ioSortArr(tmpLow) = ioSortArr(tmpHi)
          ref ioSecArr(tmpLow - iDelta), ioSecArr(tmpHi - iDelta)
          ioSortArr(tmpHi) = tmpSwapArr
          ref ioSecArr(tmpHi - iDelta), tmpSwapSec
          tmpLow = tmpLow + 1
          tmpHi = tmpHi - 1
       End If
    Wend
 
    If (inLow < tmpHi) Then x__multiQuickSort ioSortArr, ioSecArr, inLow, tmpHi, iDelta
    If (tmpLow < inHi) Then x__multiQuickSort ioSortArr, ioSecArr, tmpLow, inHi, iDelta
End Sub
 
'/**
' * Bei einer Variablenübergabe muss immer unterscheiden werden, ob es ein Objekt ist oder nicht.
' * Diese Sub nimmt einem die Arbeit ab
' * ref(oNode, iNode)
' * @param  Variant     Variable, die den Wert bekommen soll
' * @param  Variant     Ret Wert selber
' */
Private Sub ref(ByRef oNode As Variant, ByRef iNode As Variant)
    If IsObject(iNode) Then Set oNode = iNode Else oNode = iNode
End Sub