CrossSheetVLOOKUP

' CrossSheetVLOOKUP
' -----------------
' Macro Name: CrossSheetVLOOKUP
' Description: 指定したシートのA列をキーにVLOOKUPを実行し結果を現在のシートB列に出力します
' Parameters: なし
' Returns: なし
' Usage: A列にキー値があるシートでアクティブにしてから CrossSheetVLOOKUP を実行します
' -----------------

Sub CrossSheetVLOOKUP()
    On Error GoTo ErrorHandler

    Dim destWs As Worksheet
    Dim srcWs As Worksheet
    Dim refSheetName As String
    Dim colStr As String
    Dim colNum As Long
    Dim lastRow As Long
    Dim refLastRow As Long
    Dim i As Long
    Dim lookupVal As Variant
    Dim result As Variant
    Dim refRange As Range
    Dim foundCount As Long

    Set destWs = ActiveSheet

    refSheetName = InputBox("参照するシート名を入力してください", "参照シート")
    If refSheetName = "" Then Exit Sub

    On Error Resume Next
    Set srcWs = Worksheets(refSheetName)
    On Error GoTo ErrorHandler

    If srcWs Is Nothing Then
        MsgBox "シート「" & refSheetName & "」が見つかりません", vbCritical, "エラー"
        Exit Sub
    End If

    colStr = InputBox("参照シートから取得する列番号を入力してください（例: 2）", "列番号", "2")
    If colStr = "" Then Exit Sub
    If Not IsNumeric(colStr) Then
        MsgBox "数値を入力してください", vbCritical, "エラー"
        Exit Sub
    End If
    colNum = CLng(colStr)

    lastRow = destWs.Cells(destWs.Rows.Count, 1).End(xlUp).Row
    If lastRow < 2 Then
        MsgBox "現在のシートにデータが見つかりません", vbCritical, "エラー"
        Exit Sub
    End If

    refLastRow = srcWs.Cells(srcWs.Rows.Count, 1).End(xlUp).Row
    Set refRange = srcWs.Range("A1").Resize(refLastRow, colNum)

    foundCount = 0
    For i = 2 To lastRow
        lookupVal = destWs.Cells(i, 1).Value
        On Error Resume Next
        result = Application.WorksheetFunction.VLookup(lookupVal, refRange, colNum, False)
        On Error GoTo ErrorHandler
        If IsError(result) Or IsEmpty(result) Then
            destWs.Cells(i, 2).Value = "N/A"
        Else
            destWs.Cells(i, 2).Value = result
            foundCount = foundCount + 1
        End If
    Next i

    MsgBox foundCount & " 件のデータを取得しました", vbInformation, "完了"

    Exit Sub

ErrorHandler:
    MsgBox "エラーが発生しました:" & vbCrLf & Err.Description, vbCritical, "エラー"
End Sub