2 dimensional array quick sort is slow

[Hafi]

Hi,

I'm trying to create a flexible version of the recursive quick sort model where you can send the following input to the function:
'arrInput: array to sort
'sortKey: row or column to sort on
'sortOrder: xlAscending or xlDescending
'sortOrientation: xlSortRows or xlSortColumns
'header: True or False
'lngMin (optional): start row/column if sorting part of array
'lngMax (optional): end row/column if sorting part of array

The code is working fine but is very slow when the input array contains more than just a few lines of data. Already at 10 000 rows and 3 columns it takes about 4 seconds to sort the array and if I use an array with 1 000 000 rows Excel crashes. Adding one more columns to the array is not an big problem, it looks like it's the number of rows (if sorting on rows) that's the problem. I guess that the number of iterations grow exponentially when adding more rows?

Is there a way to improve the code below to make the quick sort better and faster?

Sub testSort()

Dim arr As Variant
arr = Range("A1:C10000") 'Range contains random numbers 1 - 1 000 000

t = Timer
arr = SortArrayQuick(arr, 2, xlAscending, xlSortRows, False)
Range("K1").Resize(UBound(arr), UBound(arr, 2)) = arr
MsgBox Timer - t

'Result: 4,086 seconds

End Sub


Public Function SortArrayQuick(ByRef arrInput As Variant, sortKey As Long, sortOrder As XlSortOrder, sortOrientation As XlSortOrientation, header As Boolean, Optional lngMin As Long = -1, Optional lngMax As Long = -1) As Variant

'arrInput: array to sort
'sortKey: row or column to sort on
'sortOrder: xlAscending or xlDescending
'sortOrientation: xlSortRows or xlSortColumns
'header: True or False
'lngMin (optional): start row/column if sorting part of array
'lngMax (optional): end row/column if sorting part of array


    Dim i As Long
    Dim j As Long
    Dim varMid As Variant
    Dim arrTemp As Variant
    Dim RowOrColTemp As Long

     
    If IsEmpty(arrInput) Then
        Exit Function
    End If
    If InStr(TypeName(arrInput), "()") < 1 Then
        Exit Function
    End If
    
    If lngMin = -1 Then
        If sortOrientation = xlSortRows Then
            lngMin = LBound(arrInput, 1)
        Else
            lngMin = LBound(arrInput, 2)
        End If
    End If
    
    If header = True Then
        lngMin = lngMin + 1
    End If
    
    If lngMax = -1 Then
        If sortOrientation = xlSortRows Then
            lngMax = UBound(arrInput, 1)
        Else
            lngMax = UBound(arrInput, 2)
        End If
    End If
    
    If lngMin >= lngMax Then
        Exit Function
    End If

    i = lngMin
    j = lngMax

    varMid = Empty
    If sortOrientation = xlSortRows Then
        varMid = arrInput((lngMin + lngMax) \ 2, sortKey)
    Else
        varMid = arrInput(sortKey, (lngMin + lngMax) \ 2)
    End If
       
    
    If IsObject(varMid) Then
        i = lngMax
        j = lngMin
    ElseIf IsEmpty(varMid) Then
        i = lngMax
        j = lngMin
    ElseIf IsNull(varMid) Then
        i = lngMax
        j = lngMin
    ElseIf varMid = "" Then
        i = lngMax
        j = lngMin
    ElseIf VarType(varMid) = vbError Then
        i = lngMax
        j = lngMin
    ElseIf VarType(varMid) > 17 Then
        i = lngMax
        j = lngMin
    End If

    While i <= j
        If sortOrder = xlAscending Then
            If sortOrientation = xlSortRows Then
                While arrInput(i, sortKey) < varMid And i < lngMax
                    i = i + 1
                Wend
                While varMid < arrInput(j, sortKey) And j > lngMin
                    j = j - 1
                Wend
            Else
                While arrInput(sortKey, i) < varMid And i < lngMax
                    i = i + 1
                Wend
                While varMid < arrInput(sortKey, j) And j > lngMin
                    j = j - 1
                Wend
            End If
        Else
            If sortOrientation = xlSortRows Then
                While arrInput(i, sortKey) > varMid And i < lngMax
                    i = i + 1
                Wend
                While varMid > arrInput(j, sortKey) And j > lngMin
                    j = j - 1
                Wend
            Else
                While arrInput(sortKey, i) > varMid And i < lngMax
                    i = i + 1
                Wend
                While varMid > arrInput(sortKey, j) And j > lngMin
                    j = j - 1
                Wend
            End If
        End If
        

        If i <= j Then
            If sortOrientation = xlSortRows Then
                ReDim arrTemp(LBound(arrInput, 2) To UBound(arrInput, 2))
                For RowOrColTemp = LBound(arrInput, 2) To UBound(arrInput, 2)
                    arrTemp(RowOrColTemp) = arrInput(i, RowOrColTemp)
                    arrInput(i, RowOrColTemp) = arrInput(j, RowOrColTemp)
                    arrInput(j, RowOrColTemp) = arrTemp(RowOrColTemp)
                Next RowOrColTemp
            Else
                ReDim arrTemp(LBound(arrInput, 1) To UBound(arrInput, 1))
                For RowOrColTemp = LBound(arrInput, 1) To UBound(arrInput, 1)
                    arrTemp(RowOrColTemp) = arrInput(RowOrColTemp, i)
                    arrInput(RowOrColTemp, i) = arrInput(RowOrColTemp, j)
                    arrInput(RowOrColTemp, j) = arrTemp(RowOrColTemp)
                Next RowOrColTemp
            End If
                
            Erase arrTemp
            i = i + 1
            j = j - 1
            
        End If
    Wend
    
    header = False
    
    If (lngMin < j) Then arrInput = SortArrayQuick(arrInput, sortKey, sortOrder, sortOrientation, header, lngMin, j)
    If (i < lngMax) Then arrInput = SortArrayQuick(arrInput, sortKey, sortOrder, sortOrientation, header, i, lngMax)

    SortArrayQuick = arrInput
    
End Function