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