Excel自作 VBA 関数
特定のデータを検索するVLOOKUP関数に検索列より左の列の値を抽出できる機能を追加した関数です、これを使えばＭＡＴＣＨ関数とＩＮＤＥＸ関数を組み合わせて左の列の値を抽出する必要がなくなります。XLOOKUPを目指して作りました。
VBEの標準モジュールに下のコードを登録して「Excelマクロ有効フォーム」で保存してください。
関数の登録方法は⇒♯000 ユーザー定義関数を登録する方法
登録されたら、シート上からユーザー関数「VLOOKUP2」が使用できます。
使い方は
ワークシート上で = VLOOKUP2（検索値, 範囲, 列番号(-の場合は検索値の列より左列), 検索の型）の関数として使用することで、 選択範囲より左の列の値を抽出できます。
VLOOKUP2（検索値, 範囲, 列番号(-の場合は検索値の列より左列), 検索の型）
特定のデータを検索するVLOOKUP関数で検索列より左の値も抽出できる関数。
検索列より右列を抽出する場合は列番号、左列を検索する場合は－（マイナス）の列番号を指定する。
検索列の1列左は-1,3列左は-3
検索の型 True は近似値 Falseは完全一致
[例]
VLOOKUP2(1,C1:E5,-2,FALSE)
１を完全一致の検索値にして、C1列を検索２列左であるＡ列の値を抽出する。
Function VLOOKUP2(Value As Variant, Select_Range, Col_index As Long, Optional Range_lookup As Boolean = False)
' 特定のデータを検索するVLOOKUP関数で検索列より左の値も抽出できる関数。
' 検索列より右列を抽出する場合は列番号、左列を検索する場合は－（マイナス）の列番号を指定する。
' VLOOKUP2（検索値, 範囲, 列番号(-の場合は検索値の列より左列), 検索の型）
' 検索列の1列左は-1,3列左は-3
' 検索の型 True は近似値 Falseは完全一致
Dim Select_Range1 As Variant
Dim Select_Range2 As Variant
Dim Select_Cells As String
Dim RS As String
Dim RE As String
Dim AD As String
Dim BookSeet As String
Dim Book As String
Dim Sheet As String
Dim SR As Long
Dim SC As Long
Dim ER As Long
Dim EC As Long
Dim i As Long
On Error GoTo EXITFUN
Select_Cells = Select_Range.Address(ReferenceStyle:=xlR1C1)
AD = Select_Range.Address(External:=True)
If Mid(AD, 3, InStr(AD, ".") - 4) <> ActiveWorkbook.Name Then
Book = Mid(AD, 3, InStr(AD, "]") - 3)
End If
Sheet = Mid(AD, InStr(AD, "]") + 1, InStr(AD, "!") - (InStr(AD, "]") + 1) - 1)
If InStr(Select_Cells, ":") = 0 Then
Select_Cells = Select_Cells & ":" & Select_Cells
End If
RS = Mid(Select_Cells, 1, InStr(Select_Cells, ":") - 1)
RE = Mid(Select_Cells, InStr(Select_Cells, ":") + 1)
If InStr(RS, "R") > 0 And InStr(RS, "C") > 0 Then
SR = Mid(RS, InStr(RS, "R") + 1, InStr(RS, "C") - InStr(RS, "R") - 1)
SC = Mid(RS, InStr(RS, "C") + 1)
ElseIf InStr(RS, "C") > 0 Then
SR = 1
SC = Mid(RS, InStr(RS, "R") + 1)
ElseIf InStr(RS, "R") > 0 Then
SR = Mid(RS, InStr(RS, "R") + 1)
SC = 1
End If
If InStr(RE, "R") > 0 And InStr(RE, "C") > 0 Then
ER = Mid(RE, InStr(RE, "R") + 1, InStr(RE, "C") - InStr(RE, "R") - 1)
EC = Mid(RE, InStr(RE, "C") + 1)
ElseIf InStr(RE, "C") > 0 Then
ER = 1048576
EC = Mid(RE, InStr(RE, "R") + 1)
ElseIf InStr(RE, "R") > 0 Then
ER = Mid(RE, InStr(RE, "R") + 1)
EC = 16384
End If
If SC > 1 Then
Select_Range2 = range(Workbooks(Book).Sheets(Sheet).Cells(SR, 1), _
Workbooks(Book).Sheets(Sheet).Cells(ER, SC - 1))
End If
If Abs(Col_index) > UBound(Select_Range2, 2) Then
GoTo EXITFUN
End If
Select_Range1 = Select_Range
If Range_lookup = False Then
For i = 1 To UBound(Select_Range1, 1)
If Value = Select_Range1(i, 1) Then
Exit For
End If
Next
Else
For i = 1 To UBound(Select_Range1, 1)
If Value = Select_Range1(i, 1) Then
Exit For
ElseIf i > 1 And Value < Select_Range1(i, 1) Then
i = i - 1
Exit For
End If
Next
End If
If SC > 1 And Col_index < 0 Then
VLOOKUP2 = Select_Range2(i, UBound(Select_Range2, 2) + 1 + Col_index)
Else
VLOOKUP2 = Select_Range1(i, Col_index)
End If
Exit Function
EXITFUN:
VLOOKUP2 = CVErr(xlErrNA)
End Functionここで紹介したコード使用による損害に対しては一切責任は負えません。