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
• 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
)

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