“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