This is an old revision of the document!
Ein Quicksort auf ein Array. Dabei wird ein zweiter Array mitsortiert
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
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
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 )
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