Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
Option Explicit
Function CrossLookup(lookupVariant As Variant, _
reference As Range, _
direction As String, _
offsetNum As Long _
) As Variant
'▲引数 戻り値:オフセット先の値
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つ以上の場合
GoTo Error_Handler
End If
If .Value = "" Then '値が空の場合
GoTo Error_Handler
End If
End With
End If
lookupValue = lookupVariant
With reference
If .Count > 1 Then '要素が2つ以上の場合
GoTo Error_Handler
End If
If .Value = "" Then '値が空の場合
GoTo Error_Handler
End If
End With
'v か h 以外の場合はエラー
If Not direction = VERTICAL_CHARACTER And Not direction = HORIZONTAL_CHARACTER Then
GoTo Error_Handler
End If
'垂直/水平 によって先頭と末尾取得方向を変える
If direction = VERTICAL_CHARACTER Then
directionToStart = xlUp
directionToEnd = xlDown
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
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
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