Sulprobil
Search…
Lookup Variants
"The hardest thing of all is to find a black cat in a dark room, especially if there is no cat." [Confucius]
Some LOOKUP()-Variants which I found useful:
Please read my Disclaimer.
1
Function sbLookup(vLookupValue As Variant, _
2
rTableArray As Range, _
3
Optional ByVal lOccurrence As Long = 1, _
4
Optional lColumnOffset As Long, _
5
Optional lRowOffset As Long) As Variant
6
'Reverse("moc.LiborPlus.www") PB 09-May-2010 V0.10
7
'Looks up lOccurrence'th occurrence of vLookupValue in rTableArray
8
'and returns found cell offset by lRowOffset rows and lColumnOffset
9
'columns. If lOccurrence is negative the search is done bottom-up
10
'(i.e. -1 finds the last value, -2 last but one, etc.).
11
'This function was inspired by the "Ultimate" Excel Lookup Function OzgridLookup:
12
'http://www.ozgrid.com/VBA/ultimate-excel-lookup-function.htm
13
14
Dim i As Long
15
Dim rFound As Range
16
Dim iSearchDir As Integer
17
18
If lOccurrence >= 0 Then
19
iSearchDir = xlNext
20
Else
21
iSearchDir = xlPrevious
22
lOccurrence = -lOccurrence
23
End If
24
25
With rTableArray
26
If rTableArray.Cells(1, 1) = vLookupValue And lOccurrence = 1 Then
27
sbLookup = .Cells(1, 1)(1, lColumnOffset + 1)
28
Exit Function
29
Else
30
Set rFound = .Cells(1, 1)
31
For i = 1 To lOccurrence
32
Set rFound = rTableArray.Find(What:=vLookupValue, After:=rFound, _
33
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlRows, _
34
SearchDirection:=iSearchDir)
35
Next i
36
End If
37
End With
38
39
sbLookup = rFound.Offset(lRowOffset, lColumnOffset)
40
41
End Function
Copied!
In case you need the address and not the value found:
1
Function sbLookupAddress(vLookupValue As Variant, _
2
rTableArray As Range, _
3
Optional ByVal lOccurrence As Long = 1, _
4
Optional lColumnOffset As Long, _
5
Optional lRowOffset As Long) As String
6
'Reverse("moc.LiborPlus.www") PB 26-Aug-2010 V0.10
7
'Looks up lOccurrence'th occurrence of vLookupValue in rTableArray and
8
'returns address of found cell offset by lRowOffset rows and lColumnOffset
9
'columns. If lOccurrence is negative the search is done bottom-up
10
'(i.e. -1 finds the last value, -2 last but one, etc.).
11
12
Dim i As Long
13
Dim rFound As Range, rLast As Range
14
Dim iSearchDir As Integer
15
16
If lOccurrence >= 0 Then
17
iSearchDir = xlNext
18
Else
19
iSearchDir = xlPrevious
20
lOccurrence = -lOccurrence + 1
21
End If
22
23
With rTableArray
24
If rTableArray.Cells(1, 1) = vLookupValue Then lOccurrence = lOccurrence - 1
25
If lOccurrence = 0 Then
26
sbLookupAddress = .Cells(1, 1)(1, lColumnOffset + 1).Address(False, False)
27
Exit Function
28
Else
29
Set rFound = .Cells(1, 1)
30
Set rFound = rTableArray.Find(What:=vLookupValue, After:=rFound, _
31
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlRows, _
32
SearchDirection:=iSearchDir)
33
Set rLast = rFound
34
Do
35
lOccurrence = lOccurrence - 1
36
If lOccurrence = 0 Then
37
sbLookupAddress = rFound.Offset(lRowOffset, _
38
lColumnOffset).Address(False, False)
39
Exit Function
40
End If
41
Set rFound = rTableArray.Find(What:=vLookupValue, After:=rFound, _
42
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlRows, _
43
SearchDirection:=iSearchDir)
44
Loop While rLast.Address <> rFound.Address
45
sbLookupAddress = CVErr(xlErrValue)
46
End If
47
End With
48
49
End Function
Copied!
If you need to lookup some data for ALL search values found, you can use vlookupall:
1
Function vlookupall(sSearch As String, rRange As Range, _
2
Optional lLookupCol As Long = 2, Optional sDel As String = ",") As String
3
'Vlookupall searches in first column of rRange for sSearch and returns
4
'corresponding values of column lLookupCol if sSearch was found. All these
5
'lookup values are being concatenated, delimited by sDel and returned in
6
'one string. If lLookupCol is negative then rRange must not have more than
7
'one column.
8
'Reverse("moc.LiborPlus.www") PB 16-Sep-2010 V0.20
9
Dim i As Long, sTemp As String
10
If lLookupCol > rRange.Columns.Count Or sSearch = "" Or _
11
(lLookupCol < 0 And rRange.Columns.Count > 1) Then
12
vlookupall = CVErr(xlErrValue)
13
Exit Function
14
End If
15
vlookupall = ""
16
For i = 1 To rRange.Rows.Count
17
If rRange(i, 1).Text = sSearch Then
18
If lLookupCol >= 0 Then
19
vlookupall = vlookupall & sTemp & rRange(i, lLookupCol).Text
20
Else
21
vlookupall = vlookupall & sTemp & rRange(i).Offset(0, lLookupCol).Text
22
End If
23
sTemp = sDel
24
End If
25
Next i
26
End Function
Copied!
1
Function vlookupallarr(sSearch As String, rRange As Range, _
2
Optional lLookupCol As Long = 2) As Variant
3
'Vlookupall searches in first column of rRange for sSearch and returns
4
'corresponding values of column lLookupCol if sSearch was found. All
5
'values looked up are being returned in a vertical array.
6
'If lLookupCol is negative then rRange must not have more than
7
'one column.
8
'Reverse("moc.LiborPlus.www") PB 12-Jul-2012 V0.10
9
Dim i As Long, j As Long
10
If lLookupCol > rRange.Columns.Count Or sSearch = "" Or _
11
(lLookupCol < 0 And rRange.Columns.Count > 1) Then
12
vlookupallarr = CVErr(xlErrValue)
13
Exit Function
14
End If
15
ReDim v(1 To rRange.Rows.Count)
16
For i = 1 To rRange.Rows.Count
17
If rRange(i, 1).Text = sSearch Then
18
j = j + 1
19
If lLookupCol >= 0 Then
20
v(j) = rRange(i, lLookupCol).Text
21
Else
22
v(j) = rRange(i).Offset(0, lLookupCol).Text
23
End If
24
End If
25
Next i
26
i = Application.Caller.Rows.Count
27
ReDim Preserve v(1 To i)
28
For j = j + 1 To i
29
v(j) = ""
30
Next j
31
vlookupallarr = Application.WorksheetFunction.Transpose(v)
32
End Function
Copied!
1
Function lookup2(vSV As Variant, vSA As Variant, vRA As Variant) As Variant
2
'Similar to lookup() but it looks up the biggest value in vSA which is less-equal than vSV
3
'vSA has to be sorted, lowest first!!
4
'Remember that lookup() looks up the smallest value in the search-array which is
5
'greater-equal than search-value.
6
Dim i As Long
7
i = 1
8
Do While i <= vSA.Count
9
If vSV <= vSA(i) Then
10
lookup2 = vRA(i)
11
Exit Function
12
End If
13
i = i + 1
14
Loop
15
lookup2 = "OUT OF RANGE"
16
End Function
Copied!
1
Function sbClosest(dSearchVal As Double, _
2
rLookupRange As Range, _
3
Optional dLower As Double = 0#, _
4
Optional dUpper As Double = 0#) As Variant
5
'Looks for the closest value to dSearchVal in
6
'rLookupRange which is greater or equal to dSearchVal
7
'+ dLower and less or equal to dSearchVal + dUpper.
8
'Returns that value and the address of it. xlErrNum
9
'indicates that no relevant data was found.
10
'Reverse("moc.LiborPlus.www") V0.10 16-Oct-2010 PB
11
Dim dMin As Double, v, vR(1 To 2)
12
dMin = 1E+308
13
For Each v In rLookupRange
14
If (dLower = 0# And dUpper = 0#) Or _
15
(v >= dSearchVal + dLower And _
16
v <= dSearchVal + dUpper) Then
17
If Abs(v - dSearchVal) < dMin Then
18
vR(1) = v
19
vR(2) = v.Address(False, False)
20
dMin = Abs(v - dSearchVal)
21
End If
22
End If
23
Next v
24
If dMin = 1E+308 Then
25
sbClosest = CVErr(xlErrNum)
26
Else
27
sbClosest = vR
28
End If
29
End Function
Copied!
Last modified 1yr ago
Copy link