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.

Immediate Window

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!!

• Kuba hasn't forgotten Monica: Is there any reason for this to be done in VBA? In what context is this used? Can't it be done in VB.net, and then exposed to VBA?
• TinMan: @KubaOber I wrote it to find the first and last row between two dates in an array. The code could easily be converted to other programming languages.
• TinMan: @KubaOber It could be written in another language and exposed to VBA but I see no advantage to it. A binary search over the maximum number of rows in a worksheet would only take 21 iterations.
• Kuba hasn't forgotten Monica: I completely understand, I just wonder why VBA: VB.net gives you LINQ and then the whole thing becomes a one-liner. I also suggest to have a peek at this splendid crazy hack LINQ-alike implemented in VBA. If you could use the latter, then going LINQ route would relegate hard things to library code.

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.

• TinMan: DoEvents!! Oops...I had that in there for testing. I removed it and updated my post.
• TinMan: I use the get and set prefix because Eclipse generates it's getters and setter let with them. I don't leie Get and Set and will probably consider a different name. I did not know that While...WEnd werre obsolete.
• Mathieu Guindon: You can't Exit While, that's why. Also... Java doesn't have properties ;-)
• TinMan: Originally, QuickMatch() was the only function. I added the Enum and the helper function after I completed the testing. QuickMatchInternal() and handling the cases separately is absolute genius!!
• Mathieu Guindon: @SᴀᴍOnᴇᴌᴀ I would indeed - and feel free to disagree with me and roll it back anyway (that intervention wouldn't be contrary to site rules about answer-invalidating edits), but I believe the way the edit was made (with the seams showing, i.e. it's explicitly called out), with the instruction being commented-out rather than outright removed, keeps the little DoEvents side-note relevant. IMO the Q+A as a whole remains coherent, so while it's technically invalidating, the spirit of the rule is upheld, there are far worse cases of answer invalidation edits that do warrant a rollback ;-)