4
\$\begingroup\$

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

\$\endgroup\$
4
  • \$\begingroup\$ 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? \$\endgroup\$ Sep 19 '19 at 22:37
  • \$\begingroup\$ @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. \$\endgroup\$
    – TinMan
    Sep 19 '19 at 22:52
  • 1
    \$\begingroup\$ @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. \$\endgroup\$
    – TinMan
    Sep 19 '19 at 22:59
  • \$\begingroup\$ 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. \$\endgroup\$ Sep 20 '19 at 19:12
3
\$\begingroup\$

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.

\$\endgroup\$
11
  • \$\begingroup\$ DoEvents!! Oops...I had that in there for testing. I removed it and updated my post. \$\endgroup\$
    – TinMan
    Sep 19 '19 at 18:04
  • \$\begingroup\$ 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. \$\endgroup\$
    – TinMan
    Sep 19 '19 at 18:09
  • \$\begingroup\$ You can't Exit While, that's why. Also... Java doesn't have properties ;-) \$\endgroup\$ Sep 19 '19 at 18:12
  • \$\begingroup\$ 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!! \$\endgroup\$
    – TinMan
    Sep 19 '19 at 18:21
  • 1
    \$\begingroup\$ @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 ;-) \$\endgroup\$ Sep 19 '19 at 23:34

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.