Yaslaw.Info

This page is read only. You can view the source, but not change it. Ask your administrator if you think this is wrong.
<const>
    version=1.0.0
    vdate=2019-10-17
    fname=udf_multisort.bas
    ns=%NAMESPACE%
    fpath=/vba/functions
</const>
====== [VBA] multiSort() ======
//Ein Quicksort auf ein Array. Dabei wird ein zweiter Array mitsortiert//

==Version %%version%%%%==

{{%%fname%%|Download %%fname%% (V-%%version%%)}}

===== Beschreibung ===== 


===== Definition =====
<code>bool = multisort(array-1 [,array-2 [,sortOrder]])</code>
<code vb>Public Function multiSort( _
        ByRef ioSortArr As Variant, _
        Optional ByRef ioSecArr As Variant = Null, _
        Optional ByVal iSortOder As eSortOrder = sAscending _
) As Boolean
</code>
==== Parameter-Liste ====
  ***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
  
==== Rückgabewerte ====
True. Bei einem Fehler False. Der Fehler wird im direktfenster ausgegeben

==== Enum eSortOrder ====
<code vb>Public Enum eSortOrder
    sAscending = &HA3      '(acCmdSortAscending) Aufsteigend
    sDescending = &HA4     '(acCmdSortDescending) Absteigend
End Enum</code>

===== Beispiele =====
> Für die Ausgabe der Resultate verwendete ich die Funktion [[vba:functions:print_r:index]]

==== Beispiele mit 2 Arrays ====
=== 2 gleich grosse Arrays ===
2 Arrays. Der Erste wird sortiert und der Zweite entsprechend nachgeführt
<code=vb>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
)</code>

=== 2 verschieden grosse Arrays ===
Wieder 2 Arrays, jedoch sind sie verscheiden gross
<code>'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</code>

=== Index beginnt nicht bei 0 ===
<code vb>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</code>
<code>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'
)</code>
==== Array mit Objekten nach einer Objekteigenschaft sortieren ====
Wir haben ein Array mit Objekten. Dieses wollen wir nach einer Objekteigenschaft sortieren.
\\ Ich nehme für das Beispiel [[vba:classes:date:datetime:index|]]

<code vb>    '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</code>
<code><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
	...
    )
)</code>

==== Dictionary nach Value sortieren ====
Damit kann man auch ein Dictionary sortieren
<code vb>'/**
' * 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</code>
<code vb>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</code>
<code>True
<Dictionary>  (
    [b] => <Integer> 156
    [a] => <Integer> 18974
    [c] => <Long> 99999
)</code>

===== Code =====
{{%%fname%%|Download %%fname%% (V-%%version%%)}}
Yaslaw.Info

User Tools

Site Tools

Page Tools
