Flexible Binary Search

Question

This search consists of two functions QuickMatch() which searches for the value and getQuickRowValue() which returns the value of a given row. Both functions have a SearchBy As SearchByIndex parameter which is used to determine which values will be compared. For instance: getQuickRowValue() can return [last name] or [last name] & [first name ] or [date] + [time] depending on the values you are searching. My tests are setup to test a date and time columns for a project.

Methods

Option Explicit
Public Enum SearchByIndex
    DateTime
    LastName
    LastNameFirst
End Enum

Public Function QuickMatch(ByRef Values, ByVal SearchDate As Date, SearchBy As SearchByIndex, Optional ComparisonMode As MsoFilterComparison = MsoFilterComparison.msoFilterComparisonLessThan) As Long
    Dim low As Long, high As Long, pivot As Long
    Dim Value As Variant, NextValue As Variant, PrevValue As Variant

    low = LBound(Values) + 1
    high = UBound(Values)

    Dim Count As Long

    While low <> high
        Count = Count + 1

        pivot = low + (high - low) / 2

        Value = getQuickRowValue(Values, pivot, SearchBy)
        If pivot > LBound(Values) Then PrevValue = getQuickRowValue(Values, pivot - 1, SearchBy) Else PrevValue = -1
        If pivot < UBound(Values) Then NextValue = getQuickRowValue(Values, pivot + 1, SearchBy) Else NextValue = -1

        Select Case ComparisonMode
            Case MsoFilterComparison.msoFilterComparisonEqual
                If high = pivot Then
                    QuickMatch = -1
                    Exit Function
                End If
                If Value = SearchDate Then
                    If PrevValue = -1 Or PrevValue < SearchDate Then
                        QuickMatch = pivot
                        Exit Function
                    Else
                        high = pivot - 1
                    End If
                ElseIf Value < SearchDate Then
                    If NextValue > SearchDate Then
                        QuickMatch = -1
                        Exit Function
                    Else
                        low = pivot
                    End If
                ElseIf Value > SearchDate Then
                    high = pivot
                End If
            Case MsoFilterComparison.msoFilterComparisonLessThanEqual
                If Value = SearchDate Then
                    If PrevValue = -1 Or PrevValue < SearchDate Then
                        QuickMatch = pivot
                        Exit Function
                    Else
                        high = pivot - 1
                    End If
                ElseIf Value < SearchDate Then
                    low = pivot
                ElseIf Value > SearchDate Then
                    If PrevValue = -1 Or PrevValue < SearchDate Then
                        QuickMatch = pivot
                        Exit Function
                    Else
                        high = pivot
                    End If
                End If
            Case MsoFilterComparison.msoFilterComparisonGreaterThanEqual
                If Value = SearchDate Then
                    If NextValue = -1 Or NextValue > SearchDate Then
                        QuickMatch = pivot
                        Exit Function
                    Else
                        high = pivot - 1
                    End If
                ElseIf Value < SearchDate Then
                    If NextValue = -1 Or NextValue > SearchDate Then
                        QuickMatch = pivot
                        Exit Function
                    Else
                        low = pivot
                    End If
                ElseIf Value > SearchDate Then
                    high = pivot
                End If
        End Select
        ' DoEvents was added for testing purposes to ensure that I could break the loop
        'DoEvents
    Wend

End Function

Function getQuickRowValue(ByRef Values, ByVal RowNumber As Long, SearchBy As SearchByIndex) As Variant
    Const DateColumn As Long = 1, TimeColumn As Long = 2
    Const FirstNameColumn As Long = 3, LastNameColumn As Long = 4
    Select Case SearchBy
        Case SearchByIndex.DateTime
            getQuickRowValue = Values(RowNumber, DateColumn) + Values(RowNumber, TimeColumn)
        Case SearchByIndex.LastName
            getQuickRowValue = Values(RowNumber, LastNameColumn)
        Case SearchByIndex.LastNameFirst
            getQuickRowValue = Values(RowNumber, LastNameColumn) & " " & Values(RowNumber, LastNameColumn)
    End Select
End Function

Stopwatch:Class

Option Explicit
' Accurate Performance Timers in VBA
' https://bytecomb.com/accurate-performance-timers-in-vba/
Private Declare PtrSafe Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As UINT64) As Long
Private Declare PtrSafe Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As UINT64) As Long

Private pFrequency As Double
Private pStartTS As UINT64
Private pEndTS As UINT64
Private pElapsed As Double
Private pRunning As Boolean

Private Type UINT64
    LowPart As Long
    HighPart As Long
End Type

Private Const BSHIFT_32 = 4294967296# ' 2 ^ 32

Private Function U64Dbl(U64 As UINT64) As Double
    Dim lDbl As Double, hDbl As Double
    lDbl = U64.LowPart
    hDbl = U64.HighPart
    If lDbl < 0 Then lDbl = lDbl + BSHIFT_32
    If hDbl < 0 Then hDbl = hDbl + BSHIFT_32
    U64Dbl = lDbl + BSHIFT_32 * hDbl
End Function

Private Sub Class_Initialize()
    Dim PerfFrequency As UINT64
    QueryPerformanceFrequency PerfFrequency
    pFrequency = U64Dbl(PerfFrequency)
End Sub

Public Property Get Elapsed() As Double
    If pRunning Then
        Dim pNow As UINT64
        QueryPerformanceCounter pNow
        Elapsed = pElapsed + (U64Dbl(pNow) - U64Dbl(pStartTS)) / pFrequency
    Else
        Elapsed = pElapsed
    End If
End Property

Public Sub Start()
    If Not pRunning Then
        QueryPerformanceCounter pStartTS
        pRunning = True
    End If
End Sub

Public Sub Pause()
    If pRunning Then
        QueryPerformanceCounter pEndTS
        pRunning = False
        pElapsed = pElapsed + (U64Dbl(pEndTS) - U64Dbl(pStartTS)) / pFrequency
    End If
End Sub

Public Sub Reset()
    pElapsed = 0
    pRunning = False
End Sub

Public Sub Restart()
    pElapsed = 0
    QueryPerformanceCounter pStartTS
    pRunning = True
End Sub

Public Property Get Running() As Boolean
   Running = pRunning
End Property

'I added this to simplify the testing

'I added this to simplify the testing

Public Function ElaspseTimeToString(Optional DecimalPlaces As Long = 6) As String
    Me.Pause
    ElaspseTimeToString = Format(Me.Elapsed, "0." & String(DecimalPlaces, "0")) & "ms"
End Function

Tests

Option Explicit

Sub CreateTestStub()
    Application.ScreenUpdating = False
    Const RowCount As Long = 500000
    Dim Values
    ReDim Values(1 To RowCount, 1 To 2)
    Dim d As Date, n As Long
    d = #1/1/2000#
    While n < RowCount
        n = n + 1
        d = d + TimeSerial(1, 0, 0)
        Values(n, 1) = DateValue(d)
        Values(n, 2) = TimeValue(d)
    Wend
    Range("A1").Resize(RowCount, 2).Value = Values
    Columns.AutoFit
End Sub

Sub TestQuickMatch()
    Const Tab1 = 22, Tab2 = Tab1 + 12, Tab3 = Tab2 + 12, Tab4 = Tab3 + 12, Tab5 = Tab4 + 12

    Const TestCount As Long = 5

    Dim Values
    Values = Range("A1").CurrentRegion.Value

    Dim Map As New Collection

    While Map.Count < TestCount
        Map.Add WorksheetFunction.RandBetween(1, UBound(Values))
    Wend

    Dim Stopwatch As New Stopwatch
    Dim Item
    Dim Result As Boolean
    Dim RowNumber As Long, Expected As Long
    Dim SearchDate As Date

    Debug.Print "Comparison Method"; Tab(Tab1); "Pass"; Tab(Tab2); "Time"; Tab(Tab3);
    Debug.Print "Row #"; Tab(Tab4); "Expected#"; Tab(Tab5); "Search Date"

    For Each Item In Map
        RowNumber = Item
        Expected = RowNumber ' Both Row Numbers should be Equal
        SearchDate = getQuickRowValue(Values, RowNumber, DateTime)

        Stopwatch.Start
        Result = Passes(Values, SearchDate, RowNumber, Expected, DateTime, msoFilterComparisonEqual)

        Debug.Print "Equal"; Tab(Tab1); Result; Tab(Tab2); Stopwatch.ElaspseTimeToString; Tab(Tab3);
        Debug.Print RowNumber; Tab(Tab4); Expected; Tab(Tab5); SearchDate

        Stopwatch.Reset
    Next

    For Each Item In Map
        RowNumber = Item
        Expected = -1 ' Expected = -1 becuase there is not an exact match
        SearchDate = getQuickRowValue(Values, RowNumber, DateTime) + TimeSerial(0, 1, 0)

        Stopwatch.Start
        Result = Passes(Values, SearchDate, RowNumber, Expected, DateTime, msoFilterComparisonEqual)
        Debug.Print "Equal Fail"; Tab(Tab1); Result; Tab(Tab2); Stopwatch.ElaspseTimeToString; Tab(Tab3);
        Debug.Print RowNumber; Tab(Tab4); Expected; Tab(Tab5); SearchDate
        Stopwatch.Reset
    Next

    For Each Item In Map
        RowNumber = Item
        Expected = RowNumber + 1 ' Expected is the row after RowNumber because Search Date is between the two row values
        SearchDate = getQuickRowValue(Values, RowNumber, DateTime) + TimeSerial(0, 1, 0) ' The Search Date is 1 minute more then the test row value

        Stopwatch.Start
        Result = Passes(Values, SearchDate, RowNumber, Expected, DateTime, msoFilterComparisonLessThanEqual)
        Debug.Print "Less Than Equal"; Tab(Tab1); Result; Tab(Tab2); Stopwatch.ElaspseTimeToString; Tab(Tab3);
        Debug.Print RowNumber; Tab(Tab4); Expected; Tab(Tab5); SearchDate

        Stopwatch.Reset
    Next


    For Each Item In Map
        RowNumber = Item
        Expected = RowNumber - 1 ' Expected is the row before RowNumber because Search Date is between the two row values
        SearchDate = getQuickRowValue(Values, RowNumber, DateTime) - TimeSerial(0, 1, 0) ' The Search Date is 1 minute less then the test row value

        Stopwatch.Start
        Result = Passes(Values, SearchDate, RowNumber, Expected, DateTime, msoFilterComparisonGreaterThanEqual)
        Debug.Print "Greater Than Equal"; Tab(Tab1); Result; Tab(Tab2); Stopwatch.ElaspseTimeToString; Tab(Tab3);
        Debug.Print RowNumber; Tab(Tab4); Expected; Tab(Tab5); SearchDate
        Stopwatch.Reset
    Next

End Sub

Function Passes(ByRef Values, ByVal SearchDate As Date, ByVal RowNumber As Long, Expected As Long, SearchBy As SearchByIndex, ComparisonMode As MsoFilterComparison) As Boolean
    Passes = QuickMatch(Values, SearchDate, SearchBy, ComparisonMode) = Expected
End Function

Results

Note: The time is in millisecond.

Questions

• Are there any error handlers that I should add?
• The simple comparisons work fine for my needs but comparing mixed alpha and numeric values would not work properly. The getQuickRowValue() function should probably be replaced by a method that compares 2 rows and similar to StrComp() returns -1, 0 or 1. Any suggestions?

Edit

I forgot to comment out the DoEvents and added a comment stating it was for testing purposes. Since DoEvents was not supposed to be there, I updated my post to reflect the changes in results. --Thanks Matt!!

Answer 1

I don't understand why QuickMatch would be in standard PascalCase, while getQuickRowValue would be camelCase. Public member names should be PascalCase - not something that's always obvious to do with a case-insensitive language, but it's certainly feasible. Consistency!

Dim low As Long, high As Long, pivot As Long
Dim Value As Variant, NextValue As Variant, PrevValue As Variant

low = LBound(Values) + 1
high = UBound(Values)

Might be just my opinion, but I find irrelevant (or rather, not-yet-relevant) variable declarations distracting. Avoid strings (or worse, walls) of declarations at the top of procedures; instead, declare them as they're needed. Code will read much more seamlessly, and variable declarations will always appear in the context they're relevant in:

Dim low As Long
low = LBound(Values) + 1

Dim high As Long
high = UBound(Values)

While low <> high
    '...
    DoEvents
Wend

Here I'd probably take everything in that loop body, and move it to another procedure scope. I would also replace the obsolete While...Wend with a Do While...Loop construct:

Dim low As Long
low = LBound(Values) + 1

Dim high As Long
high = UBound(Values)

Do While low <> high
    Dim count As Long
    count = count + 1
    QuickMatch = QuickMatchInternal(values, low, high, count)
Loop

And that would be the whole function's body: everything else belongs at a lower abstraction level... why DoEvents though? Code that clocks sub-millisecond execution times shouldn't need any special measures taken to help keep the UI thread responsive: DoEvents has no business anywhere, unless it's absolutely needed - in which case an explanatory comment is warranted. But commented-out, it's... dead code that should be removed.

So, this QuickMatchInternal private function would only need to be concerned about a single iteration, and needs to take its parameters ByRef.

Inside that procedure's scope, the main element that sticks out is the massive Select Case block. I'd try to break it down and move each Case to its own scope. Glancing at the code, I'd say make these Boolean-returning functions, and if they return True then we can Exit Function:

    Select Case ComparisonMode
        Case MsoFilterComparison.msoFilterComparisonEqual
            If HandleComparisonEqual(...) Then Exit Function

        Case MsoFilterComparison.msoFilterComparisonLessThanEqual
            If HandleComparisonLessThanEqual(...) Then Exit Function

        Case MsoFilterComparison.msoFilterComparisonGreaterThanEqual
            If HandleComparisonGreaterThanEqual(...) Then Exit Function

        Case Else
            '?
    End Select

...and since nothing guarantees ComparisonMode will be one of these values, there needs to be a Case Else that throws an error accordingly. The enum defines 10 members, and even if inputs are only ever one of these, there is no indication anywhere that the function is only handling a small subset of them.

The Exit Function jumps probably make the move challenging, but if the outer loop's exit condition is met by then, then there shouldn't be a problem doing that.