version=1.0.0
vdate=2019-10-17
fname=udf_multisort.bas
ns=%NAMESPACE%
fpath=/vba/functions
====== [VBA] multiSort() ======
//Ein Quicksort auf ein Array. Dabei wird ein zweiter Array mitsortiert//
==Version %%version%%%%==
{{%%fname%%|Download %%fname%% (V-%%version%%)}}
===== Beschreibung =====
===== Definition =====
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
==== 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 ====
Public Enum eSortOrder
sAscending = &HA3 '(acCmdSortAscending) Aufsteigend
sDescending = &HA4 '(acCmdSortDescending) Absteigend
End Enum
===== 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
a = array("a", "d", "b", "c")
b = array(100, 10, 1, 1000)
? multiSort(a, b)
True
print_r a
(
[#0] => 'a'
[#1] => 'b'
[#2] => 'c'
[#3] => 'd'
)
print_r b
(
[#0] => 100
[#1] => 1
[#2] => 1000
[#3] => 10
)
=== 2 verschieden grosse Arrays ===
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
=== Index beginnt nicht bei 0 ===
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:
(
[#1] =>
[#2] => 1234
[#3] => 'abc'
)
Array b:
(
[#4] => 'NR. 5'
[#5] => 'NR. 6'
[#6] => 'NR. 4'
[#7] => 'NR. 7'
)
==== 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|]]
'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
(
[#0] => (
[timeStamp] => 01.05.2018
[unixTimeStamp] => 1525132800
[dateValue] => 01.05.2018
[timeValue] => 00:00:00
...
)
[#1] => (
[timeStamp] => 01.01.2019
[unixTimeStamp] => 1546300800
[dateValue] => 01.01.2019
[timeValue] => 00:00:00
...
)
[#2] => (
[timeStamp] => 01.03.2020
[unixTimeStamp] => 1583020800
[dateValue] => 01.03.2020
[timeValue] => 00:00:00
...
)
)
==== Dictionary nach Value sortieren ====
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
(
[b] => 156
[a] => 18974
[c] => 99999
)
===== Code =====
{{%%fname%%|Download %%fname%% (V-%%version%%)}}