Ignore the posted code and use this instead.
If the range is sorted you can use a binary search and that is a lot faster.
Bear in mind that the binary search only has been used in the array method
here, not the range method.
Option Explicit
Private arr As Variant
Private bFilledRange As Boolean
Private bMadeArray As Boolean
Private bSortedLookup As Boolean
Private lStartTime As Long
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Sub test()
Dim i As Long
Dim vResult
Dim lIndex As Long
Dim rng1 As Range
Dim rng2 As Range
Dim bUseArray As Boolean
If bFilledRange = False Then
If MsgBox("Have the lookup column sorted?", vbYesNo, _
"looking up value") = vbYes Then
bSortedLookup = True
End If
FillRange bSortedLookup
bFilledRange = True
End If
Set rng1 = Range(Cells(1), Cells(65536, 1))
Set rng2 = Range(Cells(1), Cells(65536, 2))
If MsgBox("Use the array function?", vbYesNo, _
"looking up value") = vbYes Then
bUseArray = True
End If
StartSW
If bUseArray Then
vResult = GetFirstNotZero2(rng2, "AC01B1", bSortedLookup, , lIndex)
Else
vResult = GetFirstNotZero(rng1, "AC01B1", bSortedLookup, , lIndex)
End If
StopSW , "using array = " & bUseArray
MsgBox "result = " & vResult & vbCrLf & _
"Index = " & lIndex, , _
"using array = " & bUseArray
End Sub
Sub FillRange(bSort As Boolean)
Dim i As Long
Dim arr1
Dim arr2
arr1 = Array("B", "C", "D", 0, 1, 2)
arr2 = Array(0, 0, 0, 0, 0, 1, 2, 3, 4, 5)
For i = 1 To 65536
Cells(i, 1) = "A" & _
arr1(CLng(5 * Rnd)) & _
arr1(CLng(5 * Rnd)) & _
arr1(CLng(5 * Rnd)) & _
arr1(CLng(5 * Rnd)) & _
arr1(CLng(5 * Rnd))
Cells(i, 2) = arr2(CLng(9 * Rnd))
Next i
If bSort Then
Range(Cells(1), Cells(65536, 1)).Sort Key1:=Cells(1), _
Order1:=xlAscending, _
Header:=xlNo
End If
End Sub
Function GetFirstNotZero(rng As Range, _
vValue As Variant, _
bSortedLookup As Boolean, _
Optional lNotFoundReturn As Long = -1, _
Optional lReturnIndex As Long) As Variant
Dim c As Range
If bSortedLookup Then
For Each c In rng
If c.Value = vValue Then
If c.Offset(0, 1).Value <> 0 Then
lReturnIndex = c.Row
GetFirstNotZero = c.Offset(0, 1).Value
Exit Function
End If
Else
If c.Value > vValue Then
Exit For
End If
End If
Next c
Else
For Each c In rng
If c.Value = vValue Then
If c.Offset(0, 1).Value <> 0 Then
lReturnIndex = c.Row
GetFirstNotZero = c.Offset(0, 1).Value
Exit Function
End If
End If
Next c
End If
GetFirstNotZero = lNotFoundReturn
End Function
Function GetFirstNotZero2(rng As Range, _
vValue As Variant, _
bSortedLookup As Boolean, _
Optional lNotFoundReturn As Long = -1, _
Optional lReturnIndex As Long) As Variant
Dim i As Long
Dim lStartRow As Long
If bMadeArray = False Then
arr = rng
bMadeArray = True
End If
If bSortedLookup Then
lStartRow = BinarySearchVariant(vValue, arr, 1, lNotFoundReturn)
If lStartRow = lNotFoundReturn Then
GetFirstNotZero2 = lNotFoundReturn
Exit Function
End If
Do While arr(lStartRow, 1) = vValue
lStartRow = lStartRow - 1
Loop
For i = lStartRow To UBound(arr)
'Stop
If arr(i, 1) = vValue Then
If arr(i, 2) <> 0 Then
lReturnIndex = i
GetFirstNotZero2 = arr(i, 2)
Exit Function
End If
Else
If arr(i, 1) > vValue Then
Exit For
End If
End If
Next i
Else
For i = 1 To UBound(arr)
If arr(i, 1) = vValue Then
If arr(i, 2) <> 0 Then
lReturnIndex = i
GetFirstNotZero2 = arr(i, 2)
Exit Function
End If
End If
Next i
End If
GetFirstNotZero2 = lNotFoundReturn
End Function
Function BinarySearchVariant(vLookFor As Variant, _
vaArray As Variant, _
lColumn As Long, _
Optional lNotFound As Long = -1) As Long
Dim lLow As Long
Dim lMid As Long
Dim lHigh As Long
On Error GoTo PTR_Exit
'Assume we didn't find it
BinarySearchVariant = lNotFound
'Get the starting positions
lLow = LBound(vaArray)
lHigh = UBound(vaArray)
Do
'Find the midpoint of the array
lMid = (lLow + lHigh) \ 2
If vaArray(lMid, lColumn) = vLookFor Then
'We found it, so return the location and quit
BinarySearchVariant = lMid
Exit Do
ElseIf vaArray(lMid, lColumn) > vLookFor Then
'The midpoint item is bigger than us - throw away the top half
lHigh = lMid - 1
Else
'The midpoint item is smaller than us - throw away the bottom half
lLow = lMid + 1
End If
'Continue until our pointers cross
Loop Until lLow > lHigh
PTR_Exit:
End Function
Sub StartSW()
lStartTime = timeGetTime()
End Sub
Function StopSW(Optional bMsgBox As Boolean = True, _
Optional vMessage As Variant, _
Optional lMinimumTimeToShow As Long = -1) As Variant
Dim lTime As Long
lTime = timeGetTime() - lStartTime
If lTime > lMinimumTimeToShow Then
If IsMissing(vMessage) Then
StopSW = lTime
Else
StopSW = lTime & " - " & vMessage
End If
End If
If bMsgBox Then
If lTime > lMinimumTimeToShow Then
MsgBox "Done in " & lTime & " msecs", , vMessage
End If
End If
End Function
RBS
