VB - Binary Search in array (array MUST be sorted)

[CVMichael]

Use the SearchArray function do to the search

The array to search in must be sorted when you call this function, if it's not, use the code in this thread to sort first...
http://vbforums.com/showthread.php?s=&threadid=231925

Public Function SearchArray(strArr() As String, StrToSearch As String, Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) As Long
    '
    '  Made by Michael Ciurescu (CVMichael from vbforums.com)
    '  Original thread: [url]http://www.vbforums.com/showthread.php?t=231934[/url]
    '
    Dim FComp As Long, LComp As Long
    
    FComp = StrComp(StrToSearch, strArr(LBound(strArr)), Compare)
    LComp = StrComp(StrToSearch, strArr(UBound(strArr)), Compare)
    
    If FComp = -1 Then
        SearchArray = LBound(strArr) - 1 ' less than first
    ElseIf FComp = 0 Then
        SearchArray = LBound(strArr)  ' equal to first
    ElseIf LComp = 1 Then
        SearchArray = UBound(strArr) + 1 ' larger than last
    ElseIf LComp = 0 Then
        SearchArray = UBound(strArr) ' equal to last
    Else
        ' in between first and last
        SearchArray = ArrBinarySearch(strArr, StrToSearch, LBound(strArr), UBound(strArr), Compare)
    End If
End Function
 
Private Function ArrBinarySearch(strArr() As String, StrToSearch As String, ByVal First As Long, ByVal Last As Long, Optional ByVal Compare As VbCompareMethod) As Long
    '
    '  Made by Michael Ciurescu (CVMichael from vbforums.com)
    '  Original thread: [url]http://www.vbforums.com/showthread.php?t=231934[/url]
    '
    Dim Mid As Long, StrC As Long
    
    If Abs(Last - First) <= 1 Then
        ArrBinarySearch = First
    Else
        Mid = (First + Last) \ 2
        StrC = StrComp(StrToSearch, strArr(Mid), Compare)
        
        Select Case StrC
        Case -1
            ArrBinarySearch = ArrBinarySearch(strArr, StrToSearch, First, Mid)
        Case 0
            ArrBinarySearch = Mid
        Case 1
            ArrBinarySearch = ArrBinarySearch(strArr, StrToSearch, Mid, Last)
        End Select
    End If
End Function

[freescale]

Hmm.. i'm don't sure if it's only at my side, or if there's a general fail in your code.

I've switched the Parameters for StrComp, and after that it works.

Here's my code:

Option Explicit
Option Base 1
 
 
'The array to search in MUST be sorted when you call this function !!!
 
Public Function SearchArray(ByRef sArray() As String, _
                            ByRef sSearch As String, _
                            Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) As Long
                            
    Dim lLow    As Long
    Dim lHigh   As Long
    Dim sLow    As String
    Dim sHigh   As String
    Dim lFComp  As Long
    Dim lLComp  As Long
    
    On Error Resume Next
 
    lLow = LBound(sArray)
    lHigh = UBound(sArray)
        
    sLow = sArray(lLow)
    sHigh = sArray(lHigh)
    
    lFComp = StrComp(sSearch, sLow, Compare)    'First
    lLComp = StrComp(sSearch, sHigh, Compare)   'Last
    'The StrComp function has the following return values:
    '   -1      String1 sorts ahead of String2
    '    0      String1 is equal to String2
    '    1      String1 sorts after String2
    
    If lFComp <= 0 Then
        SearchArray = lLow + lFComp     'less than first or equal to first
    ElseIf lLComp >= 0 Then
        SearchArray = lHigh + lLComp    'larger than last or equal to last
    Else                                'in between first and last
        SearchArray = ArrBinarySearch(sArray, sSearch, lLow, lHigh, Compare)
    End If
End Function
 
Private Function ArrBinarySearch(ByRef sArray() As String, _
                                 ByRef sSearch As String, _
                                 ByVal lFirst As Long, _
                                 ByVal lLast As Long, _
                                 Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) As Long
                                 
    Dim lMid    As Long
    Dim lStrC   As Long
    
    On Error Resume Next
    If lFirst = lLast Then
        ArrBinarySearch = lFirst
    Else
        lMid = (lFirst + lLast) \ 2
        lStrC = StrComp(sSearch, sArray(lMid), Compare)
        
        Select Case lStrC
            Case -1
                ArrBinarySearch = ArrBinarySearch(sArray, sSearch, lFirst, lMid)
            Case 0
                ArrBinarySearch = lMid
            Case 1
                ArrBinarySearch = ArrBinarySearch(sArray, sSearch, lMid, lLast)
        End Select
    End If
End Function

lg, :mike: freescale

[CVMichael]

This is so weird !

I'm sure 100% that I've tested this before I posted and it worked fine, why all of a sudden StrComp be reversed ???

Damn Microsoft, why would they make changes like this ?

[freescale]

So, related to the "bug" (I'm don't sure if it's one) i wrote about in http://vbforums.com/showpost.php?p=2019158&postcount=3 ,

here's an example about what I mean.

I am using the normal function ArrBinarySearch, but just with 2 lines added for debugging.

Private Function ArrBinarySearch(ByRef sArray() As String, _
                                 ByRef sSearch As String, _
                                 ByVal lFirst As Long, _
                                 ByVal lLast As Long, _
                                 Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) As Long
    
    Dim lMid    As Long
    Dim lStrC   As Long
    
    On Error Resume Next
    
    If lFirst = lLast Then
        ArrBinarySearch = lFirst
    Else
        
        lMid = (lFirst + lLast) \ 2         '<-- ###########
[b]        MsgBox " "
        Debug.Print "lFirst: " & lFirst & "  lLast: " & lLast & "  -->  lMid: " & lMid[/b]
        
        lStrC = StrComp(sSearch, sArray(lMid), Compare)
        
        Select Case lStrC
            Case -1
                ArrBinarySearch = ArrBinarySearch(sArray(), sSearch, lFirst, lMid)
            Case 0
                ArrBinarySearch = lMid
            Case 1
                ArrBinarySearch = ArrBinarySearch(sArray(), sSearch, lMid, lLast)
        End Select
    End If

This one is now called by the function SearchArray, because the element i'll search for, isn't the first or the last one.

I'm calling SearchArray with

lResult = SearchArray(asMessageData(), sMessageData, vbTextCompare)

where asMessageData is the Array i've stored some Text of Mails and sMessageData is an new Mail, where i want to check if this one already exists.

This Array has an LBound of 1, and in this case, where it ends in an endless loop, the UBound of 4.
Bevore, this also happend when my UBound was 35, and all other Values after 4 chr(0).

Here's the Debug Output from the Line i've added above.

neu
neu
neu
lFirst: 1  lLast: 4  -->  lMid: 2
lFirst: 1  lLast: 2  -->  lMid: 1
lFirst: 1  lLast: 2  -->  lMid: 1
lFirst: 1  lLast: 2  -->  lMid: 1
lFirst: 1  lLast: 2  -->  lMid: 1
lFirst: 1  lLast: 2  -->  lMid: 1
lFirst: 1  lLast: 2  -->  lMid: 1
lFirst: 1  lLast: 2  -->  lMid: 1

"Neu" means, i've got a new mail, this includes that the search function has passed without any errors.

In the 4th case, as you see, it always returns to the value 1.
Don't know how to fix this

lg, freescale

[CVMichael]

You get an infinite loop when the search string is NOT in the array.
Here's the fix, it simply returns the lower index of the closest match.

Private Function ArrBinarySearch(strArr() As String, StrToSearch As String, ByVal First As Long, ByVal Last As Long, Optional ByVal Compare As VbCompareMethod) As Long
    Dim Mid As Long, StrC As Long
    
    [b]If Abs(Last - First) <= 1 Then[/b]
        ArrBinarySearch = First
    Else
        Mid = (First + Last) \ 2
        StrC = StrComp(StrToSearch, strArr(Mid), Compare)
        
        Select Case StrC
        Case -1
            ArrBinarySearch = ArrBinarySearch(strArr, StrToSearch, First, Mid)
        Case 0
            ArrBinarySearch = Mid
        Case 1
            ArrBinarySearch = ArrBinarySearch(strArr, StrToSearch, Mid, Last)
        End Select
    End If
End Function

(I also updated the main post in this thread with this change)

[freescale]

Thank you!

It's really very usefull

..and by the way.. one of the fastes i know

[sciguyryan]

Heres one I came up with, not shure how good it is compared with yours (Probably not as good ) but here it is in any case:

Function BinarySearch(strArray() As String, strSearch As String) As Long
    Dim lngIndex As Long
    Dim lngFirst As Long
    Dim lngLast As Long
    Dim lngMiddle As Long
    Dim bolInverseOrder As Boolean
    lngFirst = LBound(strArray)
    lngLast = UBound(strArray)
    bolInverseOrder = (strArray(lngFirst) > strArray(lngLast))
    BinarySearch = lngFirst - 1
    Do
        lngMiddle = (lngFirst + lngLast) \ 2
        If strArray(lngMiddle) = strSearch Then
            BinarySearch = lngMiddle
            Exit Do
        ElseIf ((strArray(lngMiddle) < strSearch) Xor bolInverseOrder) Then
            lngFirst = lngMiddle + 1
        Else
            lngLast = lngMiddle - 1
        End If
    Loop Until lngFirst > lngLast
End Function

Cheers,

RyanJ

[CVMichael]

It seems that your code is better...
I used the folloing test:

Option Explicit
 
Private MikeLoops As Long, MikeLoopsTotal As Long
Private SciguyryanLoops As Long, SciguyryanLoopsTotal As Long
 
Private Sub Form_Load()
    Dim Arr(25) As String, K As Long
    
    For K = 0 To UBound(Arr)
        Arr(K) = Chr(65 + K)
    Next K
    
    For K = 0 To UBound(Arr)
        MikeLoops = 0
        SciguyryanLoops = 0
        
        Debug.Print Arr(K), MikeLoops & " - " & SearchArray(Arr, Arr(K)), SciguyryanLoops & " - " & BinarySearch(Arr, Arr(K))
        
        MikeLoopsTotal = MikeLoopsTotal + MikeLoops
        SciguyryanLoopsTotal = SciguyryanLoopsTotal + SciguyryanLoops
    Next K
    
    Debug.Print "Mike Loops Total: " & MikeLoopsTotal, "Sciguyryan Loops Total: " & SciguyryanLoopsTotal
End Sub
 
Function BinarySearch(strArray() As String, strSearch As String) As Long
    Dim lngIndex As Long
    Dim lngFirst As Long
    Dim lngLast As Long
    Dim lngMiddle As Long
    Dim bolInverseOrder As Boolean
    
    lngFirst = LBound(strArray)
    lngLast = UBound(strArray)
    
    bolInverseOrder = (strArray(lngFirst) > strArray(lngLast))
    BinarySearch = lngFirst - 1
    
    Do
        SciguyryanLoops = SciguyryanLoops + 1
        
        lngMiddle = (lngFirst + lngLast) \ 2
        
        If strArray(lngMiddle) = strSearch Then
            BinarySearch = lngMiddle
            Exit Do
        ElseIf ((strArray(lngMiddle) < strSearch) Xor bolInverseOrder) Then
            lngFirst = lngMiddle + 1
        Else
            lngLast = lngMiddle - 1
        End If
    Loop Until lngFirst > lngLast
End Function
 
Public Function SearchArray(strArr() As String, StrToSearch As String, Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) As Long
    Dim FComp As Long, LComp As Long
    
    MikeLoops = MikeLoops + 1
    
    FComp = StrComp(StrToSearch, strArr(LBound(strArr)), Compare)
    LComp = StrComp(StrToSearch, strArr(UBound(strArr)), Compare)
    
    If FComp = -1 Then
        SearchArray = LBound(strArr) - 1 ' less than first
    ElseIf FComp = 0 Then
        SearchArray = LBound(strArr)  ' equal to first
    ElseIf LComp = 1 Then
        SearchArray = UBound(strArr) + 1 ' larger than last
    ElseIf LComp = 0 Then
        SearchArray = UBound(strArr) ' equal to last
    Else
        ' in between first and last
        SearchArray = ArrBinarySearch(strArr, StrToSearch, LBound(strArr), UBound(strArr), Compare)
    End If
End Function
 
Private Function ArrBinarySearch(strArr() As String, StrToSearch As String, ByVal First As Long, ByVal Last As Long, Optional ByVal Compare As VbCompareMethod) As Long
    Dim Mid As Long, StrC As Long
    
    MikeLoops = MikeLoops + 1
    
    If Abs(Last - First) <= 1 Then
        ArrBinarySearch = First
    Else
        Mid = (First + Last) \ 2
        StrC = StrComp(StrToSearch, strArr(Mid), Compare)
        
        Select Case StrC
        Case -1
            ArrBinarySearch = ArrBinarySearch(strArr, StrToSearch, First, Mid)
        Case 0
            ArrBinarySearch = Mid
        Case 1
            ArrBinarySearch = ArrBinarySearch(strArr, StrToSearch, Mid, Last)
        End Select
    End If
End Function

And the result:

A             1 - 0         4 - 0
B             5 - 1         5 - 1
C             6 - 2         3 - 2
D             4 - 3         4 - 3
E             5 - 4         5 - 4
F             6 - 5         2 - 5
G             3 - 6         4 - 6
H             5 - 7         5 - 7
I             6 - 8         3 - 8
J             4 - 9         5 - 9
K             5 - 10        4 - 10
L             6 - 11        5 - 11
M             2 - 12        1 - 12
N             5 - 13        4 - 13
O             6 - 14        5 - 14
P             4 - 15        3 - 15
Q             5 - 16        5 - 16
R             6 - 17        4 - 17
S             3 - 18        5 - 18
T             5 - 19        2 - 19
U             6 - 20        4 - 20
V             4 - 21        5 - 21
W             6 - 22        3 - 22
X             5 - 23        5 - 23
Y             6 - 24        4 - 24
Z             1 - 25        5 - 25
Mike Loops Total: 120       Sciguyryan Loops Total: 104

[sciguyryan]

Hmm... Thats interesting....

Well, I will still be using yours because yours is shorter and I prefer short code to long ones

I wonder if anoyne else has an even faster way to do this?

Cheers,

RyanJ

[CVMichael]

Time test:

Option Explicit
 
Private Declare Function GetTickCount Lib "kernel32" () As Long
 
Private Sub Form_Load()
    Dim Arr(25) As String, K As Long, Q As Long, Dummy As Long
    Dim StartTime As Long
    
    For K = 0 To UBound(Arr)
        Arr(K) = Chr(65 + K)
    Next K
    
    StartTime = GetTickCount
    
    For Q = 1 To 10000
        For K = 0 To UBound(Arr)
            Dummy = SearchArray(Arr, Arr(K))
        Next K
    Next Q
    
    Debug.Print "Mike time: " & GetTickCount - StartTime
    
    StartTime = GetTickCount
    
    For Q = 1 To 10000
        For K = 0 To UBound(Arr)
            Dummy = BinarySearch(Arr, Arr(K))
        Next K
    Next Q
    
    Debug.Print "Sciguyryan time: " & GetTickCount - StartTime
End Sub

Result:
Mike time: 1422
Sciguyryan time: 953

Yours is better again....

[jerry4prince]

Please how do i call binary search function to search for a record in my database and display it?
How to call my database to work with the algorithm in the function. Please some help.

[CVMichael]

You don't need binary search if your using a database.

Next time, make a thread in the database forum, and ask your question there.

[jerry4prince]

sorry for this ok, just need a quick help please. i am making a thread now in the database.

[capsulecorpjx]

Heres one I came up with, not shure how good it is compared with yours (Probably not as good ) but here it is in any case:

Function BinarySearch(strArray() As String, strSearch As String) As Long
    Dim lngIndex As Long
    Dim lngFirst As Long
    Dim lngLast As Long
    Dim lngMiddle As Long
    Dim bolInverseOrder As Boolean
    lngFirst = LBound(strArray)
    lngLast = UBound(strArray)
    bolInverseOrder = (strArray(lngFirst) > strArray(lngLast))
    BinarySearch = lngFirst - 1
    Do
        lngMiddle = (lngFirst + lngLast) \ 2
        If strArray(lngMiddle) = strSearch Then
            BinarySearch = lngMiddle
            Exit Do
        ElseIf ((strArray(lngMiddle) < strSearch) Xor bolInverseOrder) Then
            lngFirst = lngMiddle + 1
        Else
            lngLast = lngMiddle - 1
        End If
    Loop Until lngFirst > lngLast
End Function

Cheers,

RyanJ

I don't think this code will work without a "Floor" function.

When calculating the middle with "Long" datatypes, you might get .5 (5.5, 6.5, etc..).

When trying to access an array with a .5, you'll get a blank string:

For example
strArray(3.5) will return a nullstring.

[CVMichael]

Well, both of our codes use the integer division, so I don't see how you get decimals.

If you look, we are using "\" (integer division) instead of "/".

[Ellis Dee]

The reason the non-recursive one is faster is because he eliminates the just-checked value, since it has already been checked. This means his remaining pool of numbers to check shrinks by 1 every iteration compared to yours.

To generate the same performance -- though yours will probably still be trivially slower due to recursion -- change your recursive calls to:

            ArrBinarySearch = ArrBinarySearch(strArr, StrToSearch, First, Mid - 1)
        Case 0
            ArrBinarySearch = Mid
        Case 1
            ArrBinarySearch = ArrBinarySearch(strArr, StrToSearch, Mid + 1, Last)

I've been using binary searches a lot lately, and have finally realized that my old implementation for finding the first match is quite inefficient. Maybe someday I'll fix it.

Yours does not find the first match, btw; it simply stops looking whenever it finds any match. For example, if you have 100 identical items in an array your binary search will return the 50th item. This is usually undesirable.