Excel VBA 逆引き集 | XLOOKUP相当

Sub XLookup_Basic()
    Dim key As Variant, lookArray As Range, returnArray As Range, result As Variant
    key = Range("A2").Value
    Set lookArray = Range("D2:D1000")    '検索対象の列（1列でOK）
    Set returnArray = Range("F2:F1000")  '戻り値列（同じ行数）

    result = Application.WorksheetFunction.XLookup(key, lookArray, returnArray, "") '未一致は空文字
    Range("B2").Value = result
End Sub

Sub XLookup_Basic()
    Dim key As Variant, lookArray As Range, returnArray As Range, result As Variant
    key = Range("A2").Value
    Set lookArray = Range("D2:D1000")    '検索対象の列（1列でOK）
    Set returnArray = Range("F2:F1000")  '戻り値列（同じ行数）

    result = Application.WorksheetFunction.XLookup(key, lookArray, returnArray, "") '未一致は空文字
    Range("B2").Value = result
End Sub

Sub XLookup_MultiReturn()
    Dim res As Variant
    res = Application.WorksheetFunction.XLookup( _
            Range("A2").Value, Range("D2:D1000"), Range("F2:G1000"), Array("", ""), False)
    Range("B2:C2").Value = res  '2列分を一気に貼り付け
End Sub

Sub XLookup_MultiReturn()
    Dim res As Variant
    res = Application.WorksheetFunction.XLookup( _
            Range("A2").Value, Range("D2:D1000"), Range("F2:G1000"), Array("", ""), False)
    Range("B2:C2").Value = res  '2列分を一気に貼り付け
End Sub

Sub XLookup_Dictionary()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    'キー列→戻り列（複数可）を辞書化
    Dim map As Object: Set map = CreateObject("Scripting.Dictionary")
    Dim m As Range: Set m = Worksheets("Master").Range("A2:C500000") 'A:キー B,C:戻り
    Dim data As Variant: data = m.Value
    Dim i As Long, k As String
    For i = 1 To UBound(data, 1)
        k = CStr(data(i, 1))
        '戻り複数を配列で保持
        map(k) = Array(data(i, 2), data(i, 3))
    Next

    '明細側で照合（A:キー → B,Cを埋める）
    Dim last As Long: last = Cells(Rows.Count, "A").End(xlUp).Row
    Dim out As Range: Set out = Range("A2:C" & last)
    Dim v As Variant: v = out.Value
    For i = 1 To UBound(v, 1)
        k = CStr(v(i, 1))
        If map.Exists(k) Then
            v(i, 2) = map(k)(0)
            v(i, 3) = map(k)(1)
        Else
            v(i, 2) = "": v(i, 3) = ""
        End If
    Next
    out.Value = v

    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Sub XLookup_Dictionary()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    'キー列→戻り列（複数可）を辞書化
    Dim map As Object: Set map = CreateObject("Scripting.Dictionary")
    Dim m As Range: Set m = Worksheets("Master").Range("A2:C500000") 'A:キー B,C:戻り
    Dim data As Variant: data = m.Value
    Dim i As Long, k As String
    For i = 1 To UBound(data, 1)
        k = CStr(data(i, 1))
        '戻り複数を配列で保持
        map(k) = Array(data(i, 2), data(i, 3))
    Next

    '明細側で照合（A:キー → B,Cを埋める）
    Dim last As Long: last = Cells(Rows.Count, "A").End(xlUp).Row
    Dim out As Range: Set out = Range("A2:C" & last)
    Dim v As Variant: v = out.Value
    For i = 1 To UBound(v, 1)
        k = CStr(v(i, 1))
        If map.Exists(k) Then
            v(i, 2) = map(k)(0)
            v(i, 3) = map(k)(1)
        Else
            v(i, 2) = "": v(i, 3) = ""
        End If
    Next
    out.Value = v

    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Sub XLookup_Find()
    Dim key As String: key = Range("A2").Value
    Dim col As Range: Set col = Range("D2:D100000")  '検索対象
    Dim f As Range
    Set f = col.Find(What:=key, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False)
    If Not f Is Nothing Then
        Range("B2").Value = f.Offset(0, 2).Value  'D→Fへ（+2列）
    Else
        Range("B2").Value = ""
    End If
End Sub

Sub XLookup_Find()
    Dim key As String: key = Range("A2").Value
    Dim col As Range: Set col = Range("D2:D100000")  '検索対象
    Dim f As Range
    Set f = col.Find(What:=key, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False)
    If Not f Is Nothing Then
        Range("B2").Value = f.Offset(0, 2).Value  'D→Fへ（+2列）
    Else
        Range("B2").Value = ""
    End If
End Sub

Sub XLookup_Like_IndexMatch()
    Dim last As Long: last = Cells(Rows.Count, "A").End(xlUp).Row
    With Range("B2:B" & last)
        .Formula = "=IFERROR(INDEX($F$2:$F$100000, MATCH(A2, $D$2:$D$100000, 0)), """")"
        .Value = .Value  '値化して再計算負荷ゼロに
    End With
End Sub

Sub XLookup_Like_IndexMatch()
    Dim last As Long: last = Cells(Rows.Count, "A").End(xlUp).Row
    With Range("B2:B" & last)
        .Formula = "=IFERROR(INDEX($F$2:$F$100000, MATCH(A2, $D$2:$D$100000, 0)), """")"
        .Value = .Value  '値化して再計算負荷ゼロに
    End With
End Sub

Function XLOOKUP_VBA(ByVal key As Variant, look As Range, ret As Range, Optional notFound As Variant = "")
    Dim i As Long, n As Long
    n = look.Rows.Count
    If ret.Rows.Count <> n Then
        XLOOKUP_VBA = CVErr(xlErrRef)
        Exit Function
    End If
    For i = 1 To n
        If key = look.Cells(i, 1).Value Then
            XLOOKUP_VBA = ret.Cells(i, 1).Value
            Exit Function
        End If
    Next
    XLOOKUP_VBA = notFound
End Function

Function XLOOKUP_VBA(ByVal key As Variant, look As Range, ret As Range, Optional notFound As Variant = "")
    Dim i As Long, n As Long
    n = look.Rows.Count
    If ret.Rows.Count <> n Then
        XLOOKUP_VBA = CVErr(xlErrRef)
        Exit Function
    End If
    For i = 1 To n
        If key = look.Cells(i, 1).Value Then
            XLOOKUP_VBA = ret.Cells(i, 1).Value
            Exit Function
        End If
    Next
    XLOOKUP_VBA = notFound
End Function