参照式自動入力

'--------------------------------------------------
'プロシージャの概要:
'処理名:prc参照式自動入力
'概要:Sheet1のI列データ行をループし参照数式を配列に格納後、
'     Sheet2のA列へSTEP間隔で数式を入力する
'     途中に空白セルが存在する場合はメッセージを表示して処理終了
'--------------------------------------------------
Sub prc参照式自動入力()

    ' 定数定義（参照元）
    Const C_SRC_SHEET   As String  = "Sheet1"   ' 参照元シート名
    Const C_SRC_COL     As Long    = 9          ' 参照元列番号（I列=9）
    Const C_SRC_START   As Long    = 3          ' 参照元データ開始行

    ' 定数定義（書き込み先）
    Const C_DST_SHEET   As String  = "Sheet2"   ' 書き込み先シート名
    Const C_DST_COL     As Long    = 1          ' 書き込み先列番号（A列=1）
    Const C_DST_START   As Long    = 2          ' 書き込み先開始行
    Const C_DST_STEP    As Long    = 3          ' 書き込み先の行間隔

    ' 変数定義
    Dim wsSrc           As Worksheet   ' 参照元シート（Sheet1）
    Dim wsDst           As Worksheet   ' 書き込み先シート（Sheet2）
    Dim lngLastRow      As Long        ' 参照元I列の終端行番号
    Dim lngSrcRow       As Long        ' 参照元ループカウンタ
    Dim lngDstRow       As Long        ' 書き込み先の現在行番号
    Dim lngIdx          As Long        ' 配列インデックス
    Dim strCellAddr     As String      ' 空白検出時のセル番地
    Dim arrStrFormula() As String      ' 参照数式文字列の格納配列

    ' シートオブジェクト取得
    Set wsSrc = ThisWorkbook.Worksheets(C_SRC_SHEET)
    Set wsDst = ThisWorkbook.Worksheets(C_DST_SHEET)

    ' I列の終端行取得（最終行から上方向に検索）
    lngLastRow = wsSrc.Cells(wsSrc.Rows.Count, C_SRC_COL).End(xlUp).Row

    ' データ存在チェック
    If lngLastRow < C_SRC_START Then
        MsgBox "参照元データが存在しない。", vbExclamation
        Exit Sub
    End If

    ' データ件数分の配列を確保（0始まり）
    ReDim arrStrFormula(0 To lngLastRow - C_SRC_START)

    ' I列をループして参照数式文字列を配列に格納
    ' 空白セルが存在する場合はセル番地を表示して処理終了
    lngIdx = 0
    For lngSrcRow = C_SRC_START To lngLastRow

        ' 空白セルチェック
        If wsSrc.Cells(lngSrcRow, C_SRC_COL).Value = "" Then
            strCellAddr = wsSrc.Cells(lngSrcRow, C_SRC_COL).Address(False, False)
            MsgBox "セル" & strCellAddr & "が空白です。", vbExclamation
            Exit Sub
        End If

        ' 参照数式文字列を生成して配列に格納（例："=Sheet1!I3"）
        arrStrFormula(lngIdx) = "=" & C_SRC_SHEET & "!" & _
            wsSrc.Cells(lngSrcRow, C_SRC_COL).Address(False, False)
        lngIdx = lngIdx + 1

    Next lngSrcRow

    ' 配列の数式をSheet2のA列へSTEP間隔で入力（A2→A5→A8...）
    lngIdx    = 0
    lngDstRow = C_DST_START
    Do While lngIdx <= UBound(arrStrFormula)
        wsDst.Cells(lngDstRow, C_DST_COL).Formula = arrStrFormula(lngIdx)
        lngIdx    = lngIdx + 1
        lngDstRow = lngDstRow + C_DST_STEP
    Loop

    MsgBox "数式の入力が完了した。", vbInformation

End Sub