New-C02

Option Explicit

'+++*******************************************************+++
'    myXLOOKUP風コード（辞書を使った高速検索・値の転記）
'    指定したシート・列をもとに、検索キーに対応する値を取得して
'    別のシートに書き込む。XLOOKUPのような動作をVBAで再現。
'    Call RunXlookupStyle_ByColumn_Inline(GetXlookupConfig)
'+++*******************************************************+++
Sub RunXlookupStyle_ByColumn_Inline(ByVal config As Collection)
    Dim inputSheet As Worksheet, lookupSheet As Worksheet
    Dim keyRange As Range, searchColRange As Range, returnColRange As Range
    Dim resultArray As Variant, dict As Dictionary
    Dim i As Long, keyVal As String
    Dim actMaxRow As Long, MaxRow As Long
    Dim myRow As Long, myCol As Long
    Dim fmtType As Long

    '=== 初期化 ===
    Call StopUpdating
    Application.Calculation = xlCalculationManual

    '=== 設定の取得 ===
    Set lookupSheet = Worksheets(config(1))
    Set inputSheet = Worksheets(config(2))
    myRow = config(7)
    myCol = config(8)
    fmtType = config(9)

    '=== 検索キー範囲の取得 ===
    actMaxRow = inputSheet.Cells(inputSheet.Rows.Count, config(6)).End(xlUp).Row
    Set keyRange = inputSheet.Range(inputSheet.Cells(myRow, config(6)), inputSheet.Cells(actMaxRow, config(6)))

    '=== 検索対象・戻り値の範囲取得 ===
    With lookupSheet
        MaxRow = .Cells(.Rows.Count, config(4)).End(xlUp).Row
        Set searchColRange = .Range(.Cells(config(3), config(4)), .Cells(MaxRow, config(4)))
        Set returnColRange = .Range(.Cells(config(3), config(5)), .Cells(MaxRow, config(5)))
    End With

    '=== 辞書に登録 ===
    Set dict = New Dictionary
    For i = 1 To searchColRange.Rows.Count
        keyVal = CStr(searchColRange.Cells(i, 1).Value)
        If Not dict.Exists(keyVal) Then dict.Add keyVal, CStr(returnColRange.Cells(i, 1).Value)
    Next i

    '=== 結果配列の初期化と検索 ===
    ReDim resultArray(1 To keyRange.Rows.Count, 1 To 1)
    For i = 1 To keyRange.Rows.Count
        keyVal = CStr(keyRange.Cells(i, 1).Value)
        If dict.Exists(keyVal) Then
            resultArray(i, 1) = dict(keyVal)
        Else
            resultArray(i, 1) = "'"       ' 見つからない場合
        End If
    Next i

    '=== 書式設定と出力 ===
    With inputSheet
        Select Case fmtType
            Case 1: .Range(.Cells(myRow, myCol), .Cells(actMaxRow, myCol)).NumberFormatLocal = "@"
            Case 2: .Range(.Cells(myRow, myCol), .Cells(actMaxRow, myCol)).NumberFormatLocal = "#0"
            Case 3: .Range(.Cells(myRow, myCol), .Cells(actMaxRow, myCol)).NumberFormatLocal = "#,##0"
            Case 4: .Range(.Cells(myRow, myCol), .Cells(actMaxRow, myCol)).NumberFormatLocal = "yyyy/m/d"
        End Select
        .Range(.Cells(myRow, myCol), .Cells(actMaxRow, myCol)).Value = resultArray
    End With

    '=== 後処理 ===
    Set dict = Nothing
    Call Updating
    MsgBox "XLOOKUP風の結果を値として書き込みました！"
End Sub

'=== XLOOKUP風処理の設定情報を返す ===
Function GetXlookupConfig() As Collection
    Dim config As New Collection

    config.Add "反映元シード"      ' 1: 検索元シート名
    config.Add "反映先シート"      ' 2: 書き込み先シート名
    config.Add 2                   ' 3: 検索元の開始行
    config.Add 4                   ' 4: 検索対象の列番号
    config.Add 5                   ' 5: 戻り値の列番号
    config.Add 13                  ' 6: 検索キーの列番号（反映先）
    config.Add 2                   ' 7: 書き込み開始行
    config.Add 1                   ' 8: 書き込み列番号
    config.Add 1                   ' 9: 書式設定（1:文字列, 2:数値, 3:カンマ付き, 4:日付）

    Set GetXlookupConfig = config
End Function