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

Printable View

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

VB Code:

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

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

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:

VB 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

May 19th, 2005, 12:09 PM
CVMichael

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

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 ?

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

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.
VB Code:
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
VB Code:
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.

Code:

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 :rolleyes:

lg, freescale :duck:

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

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.

VB Code:

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)

May 24th, 2005, 04:37 AM
freescale

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

Thank you!

It's really very usefull :)

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

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

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:

VB Code:

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

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

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

VB Code:

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:

Code:

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

May 25th, 2005, 01:21 PM
sciguyryan

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

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 :)

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

Time test:

VB Code:

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

Aug 22nd, 2010, 03:48 PM
jerry4prince

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

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.
Aug 22nd, 2010, 10:12 PM
CVMichael

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

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.
Aug 23rd, 2010, 02:11 PM
jerry4prince

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

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

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

Quote:

Originally Posted by 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:

VB Code:

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.

Oct 12th, 2010, 07:56 PM
CVMichael

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

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 "/".
Nov 23rd, 2010, 04:23 AM
Ellis Dee

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

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:

Code:

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.