Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
VBA
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment