“The hardest thing of all is to find a black cat in a dark room, especially if there is no cat.” [Confucius]
Abstract
Hier stelle ich einige VERWEIS (LOOKUP) Varianten vor, die ich hilfreich finde:
sbLookup
sbClosest
sbLookupAddress
Vlookupall
Vlookupallarr
Lookup2
Appendix – Programmcode sbLookup
Bitte den Haftungsausschluss im Impressum beachten.
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
Appendix – Programmcode sbClosest
Bitte den Haftungsausschluss im Impressum beachten.
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
Appendix – Programmcode sbLookupAddress
Bitte den Haftungsausschluss im Impressum beachten.
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
Appendix – Programmcode Vlookupall
Bitte den Haftungsausschluss im Impressum beachten.
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
Appendix – Programmcode Vlookupallarr
Bitte den Haftungsausschluss im Impressum beachten.
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
Appendix – Programmcode lookup2
Bitte den Haftungsausschluss im Impressum beachten.
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