VBA

CrossLookUp.bas

Option Explicit

Function CrossLookup(lookupVariant As Variant, _
                      reference As Range, _
                      direction As String, _
                      offsetNum As Long _
                     ) As Variant

                    '▼引数
                        '検索値：variant。Rangeの場合処理を分ける
                        '参照セル：単一セル
                        '方向（垂直/水平）：文字列
                        'オフセット数：長整数
                    '▲引数 戻り値：オフセット先の値

    'エラーメッセージ
    Const LOOKUPVALUE_RANGE_ERRORMSG As String = "検索値の範囲エラー"
    Const LOOKUPVALUE_VALUE_ERRORMSG As String = "検索値がありません"
    Const REFERENCE_RANGE_ERRORMSG As String = "参照値の範囲エラー"
    Const REFERENCE_VALUE_ERRORMSG As String = "参照値がありません"
    Const DERECTION_ERRORMSG As String = "方向エラー（v か h）"
    Const NOTFOUND_ERRORMSG As String = "見つかりません"
    
    'ルックアップ方向
    Const VERTICAL_CHARACTER As String = "v" '垂直文字列
    Const HORIZONTAL_CHARACTER As String = "h" '水平文字列
    
    '検索用変数
    Dim lookupValue As String '検索値文字列
    Dim searchStartAddress As String '検索範囲先頭
    Dim searchEndAddress As String '検索範囲末尾
    Dim searchRange As Range '検索範囲
    Dim directionToStart As XlDirection '先頭方向
    Dim directionToEnd As XlDirection '末尾方向
    Dim dataTemp As Variant '検索範囲を配列に格納
    Dim i As Long 'カウンタ
    Dim hitFlg As Boolean '発見フラグ
    
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    
    '検索値エラーチェック
      '検索値指定が Range オブジェクトか判定
    If TypeName(lookupVariant) = "Range" Then
        With lookupVariant
            If .Count > 1 Then '要素が2つ以上の場合
                CrossLookup = LOOKUPVALUE_RANGE_ERRORMSG
                GoTo Error_Handler
            End If
            If .Value = "" Then '値が空の場合
                CrossLookup = LOOKUPVALUE_VALUE_ERRORMSG
                GoTo Error_Handler
            End If
        End With
    End If
    
    lookupValue = lookupVariant
    
    '参照値エラーチェック
    With reference
        If .Count > 1 Then '要素が2つ以上の場合
            CrossLookup = REFERENCE_RANGE_ERRORMSG
            GoTo Error_Handler
        End If
        If .Value = "" Then '値が空の場合
            CrossLookup = REFERENCE_VALUE_ERRORMSG
            GoTo Error_Handler
        End If
    End With
    
    '方向文字列判定
      'v か h 以外の場合はエラー
    If Not direction = VERTICAL_CHARACTER And Not direction = HORIZONTAL_CHARACTER Then
        CrossLookup = DERECTION_ERRORMSG
        GoTo Error_Handler
    End If
    
    '垂直/水平　によって先頭と末尾取得方向を変える
    If direction = VERTICAL_CHARACTER Then
        directionToStart = xlUp
        directionToEnd = xlDown
    Else
        directionToStart = xlToLeft
        directionToEnd = xlToRight
    End If
    
    '先頭と末尾のアドレス取得
    searchStartAddress = reference.End(directionToStart).Address(external:=True)
    searchEndAddress = reference.End(directionToEnd).Address(external:=True)
    
    '検索範囲オブジェクトセット
    Set searchRange = Range(searchStartAddress & ":" & searchEndAddress)
    
    '検索範囲を配列に格納
    dataTemp = searchRange
    
    '配列の検索
    hitFlg = False
    If direction = VERTICAL_CHARACTER Then
        For i = 1 To UBound(dataTemp, 1)
            If lookupValue = dataTemp(i, 1) Then
                hitFlg = True
                CrossLookup = searchRange.Item(i).Offset(0, offsetNum) 'v なら水平
                Exit For
            End If
        Next i
    Else
        For i = 1 To UBound(dataTemp, 2)
            If lookupValue = dataTemp(1, i) Then
                hitFlg = True
                CrossLookup = searchRange.Item(i).Offset(offsetNum, 0) 'h なら垂直
                Exit For
            End If
        Next i
    End If
    
    If Not hitFlg Then CrossLookup = NOTFOUND_ERRORMSG
    
Error_Handler:
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Function