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