Sorting & searching 2-dimensional arrays

[Ellis Dee]

EDIT: Though clever, this isn't an optimal implementation. All the cuteness with swapping out dimension references slows the whole thing down about 33%. For better performance, see this thread.
[/EDIT]

Here is a module you can add to your project if you need to sort and/or search a two dimensional array. Both the sort and search work on either dimension.

The module includes a test function for demonstration.

' Written by Ellis Dee
Option Explicit
Option Compare Text

Public Sub TestSort()
    Dim lngRow As Long
    Dim lngCol As Long
    Dim MyArray() As Variant
    Dim strFind As String
    
    Randomize Timer
    Debug.Print "Row, Column (Generally a fixed array)"
    ReDim MyArray(10 To 20, 2 To 3)
    For lngRow = LBound(MyArray, 1) To UBound(MyArray, 1)
        MyArray(lngRow, 2) = Chr(Int((90 - 65 + 1) * Rnd + 65))
        MyArray(lngRow, 3) = Int((199 - 100 + 1) * Rnd + 100)
        Debug.Print lngRow & ": " & MyArray(lngRow, 2) & ", " & MyArray(lngRow, 3)
    Next
    QuickSort MyArray, 2, 2
    Debug.Print "Sorted"
    For lngRow = LBound(MyArray, 1) To UBound(MyArray, 1)
        Debug.Print lngRow & ": " & MyArray(lngRow, 2) & ", " & MyArray(lngRow, 3)
    Next
    Debug.Print "Array index of first 'Q': " & BinarySearch(MyArray, 2, 2, "Q")
    Debug.Print
    Debug.Print "Column, Row (Generally a dynamic array)"
    ReDim MyArray(2 To 3, 10 To 20)
    For lngRow = LBound(MyArray, 2) To UBound(MyArray, 2)
        MyArray(2, lngRow) = Chr(Int((90 - 65 + 1) * Rnd + 65))
        MyArray(3, lngRow) = Int((199 - 100 + 1) * Rnd + 100)
        Debug.Print lngRow & ": " & MyArray(2, lngRow) & ", " & MyArray(3, lngRow)
    Next
    QuickSort MyArray, 1, 2
    Debug.Print "Sorted"
    For lngRow = LBound(MyArray, 2) To UBound(MyArray, 2)
        Debug.Print lngRow & ": " & MyArray(2, lngRow) & ", " & MyArray(3, lngRow)
    Next
    Debug.Print "Array index of first 'Q': " & BinarySearch(MyArray, 1, 2, "Q")
    Erase MyArray
End Function

' Sort a 2-dimensional array on either dimension
' Omit plngLeft & plngRight; they are used internally during recursion
' Sample usage to sort on column 4
' Dim MyArray(1 to 1000, 1 to 5) As Long
' QuickSort MyArray, 2, 4
' Dim MyArray(1 to 5, 1 to 1000) As Long
' QuickSort MyArray, 1, 4
Public Sub QuickSort(pArray As Variant, pbytDimension As Byte, plngColumn As Long, Optional ByVal plngLeft As Long, Optional ByVal plngRight As Long)
    Dim i As Long
    Dim lngFirst As Long
    Dim lngLast As Long
    Dim vFirst As Variant
    Dim vMid As Variant
    Dim vLast As Variant
    Dim lDim(1 To 2) As Long
    Dim bytCol As Byte
    Dim bytRow As Byte
    
    bytRow = -pbytDimension + 3
    bytCol = pbytDimension
    If plngRight = 0 Then
        plngLeft = LBound(pArray, bytRow)
        plngRight = UBound(pArray, bytRow)
    End If
    lngFirst = plngLeft
    lngLast = plngRight
    lDim(bytRow) = (plngLeft + plngRight) \ 2
    lDim(bytCol) = plngColumn
    vMid = pArray(lDim(1), lDim(2))
    Do
        lDim(bytRow) = lngFirst
        lDim(bytCol) = plngColumn
        Do While pArray(lDim(1), lDim(2)) < vMid And lngFirst < plngRight
            lngFirst = lngFirst + 1
            lDim(bytRow) = lngFirst
        Loop
        lDim(bytRow) = lngLast
        Do While vMid < pArray(lDim(1), lDim(2)) And lngLast > plngLeft
            lngLast = lngLast - 1
            lDim(bytRow) = lngLast
        Loop
        If lngFirst <= lngLast Then
            For i = LBound(pArray, bytCol) To UBound(pArray, bytCol)
                lDim(bytCol) = i
                lDim(bytRow) = lngFirst
                vFirst = pArray(lDim(1), lDim(2))
                lDim(bytRow) = lngLast
                vLast = pArray(lDim(1), lDim(2))
                pArray(lDim(1), lDim(2)) = vFirst
                lDim(bytRow) = lngFirst
                pArray(lDim(1), lDim(2)) = vLast
            Next
            lngFirst = lngFirst + 1
            lngLast = lngLast - 1
        End If
    Loop Until lngFirst > lngLast
    If plngLeft < lngLast Then QuickSort pArray, pbytDimension, plngColumn, plngLeft, lngLast
    If lngFirst < plngRight Then QuickSort pArray, pbytDimension, plngColumn, lngFirst, plngRight
End Sub

' Simple binary search. Be sure array is sorted first.
' Sample usage to locate ID from column 1
' Dim MyArray(1 to 1000, 1 to 5) As Long
' lngIndex = BinarySearch(MyArray, 2, 1, lngIDToFind)
' Dim MyArray(1 to 5, 1 to 1000) As Long
' lngIndex = BinarySearch(MyArray, 1, 1, lngIDToFind)
Public Function BinarySearch(pArray As Variant, pbytDimension As Byte, plngColumn As Long, pvarFind As Variant) As Long
    Dim lngFirst As Long
    Dim lngMid As Long
    Dim lngLast As Long
    Dim lDim(1 To 2) As Long
    Dim bytCol As Byte
    Dim bytRow As Byte
    
    bytRow = -pbytDimension + 3
    bytCol = pbytDimension
    lDim(bytCol) = plngColumn
    BinarySearch = -1
    lngMid = -1
    lngFirst = LBound(pArray, bytRow)
    lngLast = UBound(pArray, bytRow)
    Do While lngFirst <= lngLast
        lngMid = (lngFirst + lngLast) \ 2
        lDim(bytRow) = lngMid
        If pArray(lDim(1), lDim(2)) > pvarFind Then
            lngLast = lngMid - 1
        ElseIf pArray(lDim(1), lDim(2)) < pvarFind Then
            lngFirst = lngMid + 1
        Else
            Exit Do
        End If
    Loop
    ' Make sure this is the first match in array
    Do While lngMid > lngFirst
        lDim(bytRow) = lngMid - 1
        If pArray(lDim(1), lDim(2)) <> pvarFind Then Exit Do
        lngMid = lngMid - 1
    Loop
    ' Set return value if match was found
    If lngMid > -1 Then
        lDim(bytRow) = lngMid
        If pArray(lDim(1), lDim(2)) = pvarFind Then BinarySearch = lngMid
    End If
End Function