I am a supporter of
St. Joseph's hospice.
 If you find this site useful or if it helped you, consider a small donation to
St. Joseph's, please.

Information on
St. Joseph's

JustGiving - Sponsor me now!

 

LOOKUP-Variants

"When your work speaks for itself, don't interrupt." [Henry J. Kaiser]

Some LOOKUP()-Variants which I found useful:

Function sbLookup(vLookupValue As Variant, _
            rTableArray As Range, _
            Optional ByVal lOccurrence As Long = 1, _
            Optional lColumnOffset As Long, _
            Optional lRowOffset As Long) As Variant
'Reverse("moc.LiborPlus.www") PB 09-May-2010 V0.10
'Looks up lOccurrence'th occurrence of vLookupValue in rTableArray
'and returns found cell offset by lRowOffset rows and lColumnOffset
'columns. If lOccurrence is negative the search is done bottom-up
'(i.e. -1 finds the last value, -2 last but one, etc.).
'This function was inspired by the "Ultimate" Excel Lookup Function OzgridLookup:
'http://www.ozgrid.com/VBA/ultimate-excel-lookup-function.htm

Dim i As Long
Dim rFound As Range
Dim iSearchDir As Integer

If lOccurrence >= 0 Then
    iSearchDir = xlNext
Else
    iSearchDir = xlPrevious
    lOccurrence = -lOccurrence
End If

With rTableArray
    If rTableArray.Cells(1, 1) = vLookupValue And lOccurrence = 1 Then
        sbLookup = .Cells(1, 1)(1, lColumnOffset + 1)
        Exit Function
    Else
        Set rFound = .Cells(1, 1)
        For i = 1 To lOccurrence
            Set rFound = rTableArray.Find(What:=vLookupValue, After:=rFound, _
                    LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlRows, _
                    SearchDirection:=iSearchDir)
        Next i
    End If
End With

sbLookup = rFound.Offset(lRowOffset, lColumnOffset)

End Function

If you need the address and not the found value:

20100826_PB_01_sbVlookupAddress

A 19 KB Excel 2007 © sample file you can find here, open and use at your own risk, please read my disclaimer.

If this function should not return an error value in case the lookup value does not occur as often as the occurrence parameter, apply the algorithm of sbVlookup mentioned above.

Function sbLookupAddress(vLookupValue As Variant, _
            rTableArray As Range, _
            Optional ByVal lOccurrence As Long = 1, _
            Optional lColumnOffset As Long, _
            Optional lRowOffset As Long) As String
'Reverse("moc.LiborPlus.www") PB 26-Aug-2010 V0.10
'Looks up lOccurrence'th occurrence of vLookupValue in rTableArray and
'returns address of found cell offset by lRowOffset rows and lColumnOffset
'columns. If lOccurrence is negative the search is done bottom-up
'(i.e. -1 finds the last value, -2 last but one, etc.).

Dim i As Long
Dim rFound As Range, rLast As Range
Dim iSearchDir As Integer

If lOccurrence >= 0 Then
    iSearchDir = xlNext
Else
    iSearchDir = xlPrevious
    lOccurrence = -lOccurrence + 1
End If

With rTableArray
    If rTableArray.Cells(1, 1) = vLookupValue Then lOccurrence = lOccurrence - 1
    If lOccurrence = 0 Then
        sbLookupAddress = .Cells(1, 1)(1, lColumnOffset + 1).Address(False, False)
        Exit Function
    Else
        Set rFound = .Cells(1, 1)
        Set rFound = rTableArray.Find(What:=vLookupValue, After:=rFound, _
                LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlRows, _
                SearchDirection:=iSearchDir)
        Set rLast = rFound
        Do
            lOccurrence = lOccurrence - 1
            If lOccurrence = 0 Then
                sbLookupAddress = rFound.Offset(lRowOffset, _
                                  lColumnOffset).Address(False, False)
                Exit Function
            End If
            Set rFound = rTableArray.Find(What:=vLookupValue, After:=rFound, _
                    LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlRows, _
                    SearchDirection:=iSearchDir)
        Loop While rLast.Address <> rFound.Address
        sbLookupAddress = CVErr(xlErrValue)
    End If
End With

End Function

If you need to lookup some data for ALL search values found, you can use vlookupall:

20100902_PB_01_Vlookupall
20100902_PB_02_Vlookupall

A 46 KB Excel 2003 © sample file you can find here, open and use at your own risk, please read my disclaimer.

Function vlookupall(sSearch As String, rRange As Range, _
    Optional lLookupCol As Long = 2, Optional sDel As String = ",") As String
'Vlookupall searches in first column of rRange for sSearch and returns
'corresponding values of column lLookupCol if sSearch was found. All these
'lookup values are being concatenated, delimited by sDel and returned in
'one string. If lLookupCol is negative then rRange must not have more than
'one column.
'Reverse("moc.LiborPlus.www") PB 16-Sep-2010 V0.20
Dim i As Long, sTemp As String
If lLookupCol > rRange.Columns.Count Or sSearch = "" Or _
    (lLookupCol < 0 And rRange.Columns.Count > 1) Then
    vlookupall = CVErr(xlErrValue)
    Exit Function
End If
vlookupall = ""
For i = 1 To rRange.Rows.Count
    If rRange(i, 1).Text = sSearch Then
        If lLookupCol >= 0 Then
            vlookupall = vlookupall & sTemp & rRange(i, lLookupCol).Text
        Else
            vlookupall = vlookupall & sTemp & rRange(i).Offset(0, lLookupCol).Text
        End If
        sTemp = sDel
    End If
Next i
End Function

Function vlookupallarr(sSearch As String, rRange As Range, _
    Optional lLookupCol As Long = 2) As Variant
'Vlookupall searches in first column of rRange for sSearch and returns
'corresponding values of column lLookupCol if sSearch was found. All
'values looked up are being returned in a vertical array.
'If lLookupCol is negative then rRange must not have more than
'one column.
'Reverse("moc.LiborPlus.www") PB 12-Jul-2012 V0.10
Dim i As Long, j As Long
If lLookupCol > rRange.Columns.Count Or sSearch = "" Or _
    (lLookupCol < 0 And rRange.Columns.Count > 1) Then
    vlookupallarr = CVErr(xlErrValue)
    Exit Function
End If
ReDim v(1 To rRange.Rows.Count)
For i = 1 To rRange.Rows.Count
    If rRange(i, 1).Text = sSearch Then
        j = j + 1
        If lLookupCol >= 0 Then
            v(j) = rRange(i, lLookupCol).Text
        Else
            v(j) = rRange(i).Offset(0, lLookupCol).Text
        End If
    End If
Next i
i = Application.Caller.Rows.Count
ReDim Preserve v(1 To i)
For j = j + 1 To i
    v(j) = ""
Next j
vlookupallarr = Application.WorksheetFunction.Transpose(v)
End Function

Function lookup2(vSV As Variant, vSA As Variant, vRA As Variant) As Variant
'Similar to lookup() but it looks up the biggest value in vSA which is less-equal than vSV
'vSA has to be sorted, lowest first!!
'Remember that lookup() looks up the smallest value in the search-array which is
'greater-equal than search-value.
Dim i As Long
i = 1
Do While i <= vSA.Count
    If vSV <= vSA(i) Then
        lookup2 = vRA(i)
        Exit Function
    End If
    i = i + 1
Loop
lookup2 = "OUT OF RANGE"
End Function

Function sbClosest(dSearchVal As Double, _
    rLookupRange As Range, _
    Optional dLower As Double = 0#, _
    Optional dUpper As Double = 0#) As Variant
'Looks for the closest value to dSearchVal in
'rLookupRange which is greater or equal to dSearchVal
'+ dLower and less or equal to dSearchVal + dUpper.
'Returns that value and the address of it. xlErrNum
'indicates that no relevant data was found.
'Reverse("moc.LiborPlus.www") V0.10 16-Oct-2010 PB
Dim dMin As Double, v, vR(1 To 2)
dMin = 1E+308
For Each v In rLookupRange
    If (dLower = 0# And dUpper = 0#) Or _
        (v >= dSearchVal + dLower And _
        v <= dSearchVal + dUpper) Then
            If Abs(v - dSearchVal) < dMin Then
                vR(1) = v
                vR(2) = v.Address(False, False)
                dMin = Abs(v - dSearchVal)
            End If
    End If
Next v
If dMin = 1E+308 Then
    sbClosest = CVErr(xlErrNum)
Else
    sbClosest = vR
End If
End Function

Sulprobil   Get it done   Contact   Disclaimer   Download