別ファイルのセル取得

VBAを実行しているファイルとは別のExcelファイルのデータをVBAを実行しているファイルのセルにもってくる(コピーする)プログラムを作成しました。データが入力してあるファイルは同じフォーマットの表を含む2ファイルにしました。












プログラムの処理としては、表のRangeオブジェクトを取得し、VBAを実行しているファイルのセルでRangeオブジェクトの内容を書き出すようにしました。もし、2ファイル以降ある場合は、再度同じ処理をし(ループを行い)、書き込む処理のところだけ書き込み位置を空白セルまでずらす処理をいれました。以下がプログラムです。

Option Explicit

Public Const READ_START_ROW = 5         '読み込みセルの最初の行を設定
Public Const READ_START_COLUMN = 2      '読み込みセルの最初の列を設定
Public Const READ_END_COLUMN = 4        '読み込みセルの最後の列を設定
Public Const WRITE_START_ROW = 7        '書き込みセルの最初の行を設定
Public Const WRITE_FIRST_COLUMN = 3     '書き込みセルの１番目の列を設定
Public Const WRITE_SECOND_COLUMN = 4    '書き込みセルの2番目の列を設定

Public Sub getdaiary()

    '変数定義
    Dim fPath As String
    Dim fcnt As Integer
    Dim i As Integer
    Dim excWB As Workbook
    Dim getWB As Workbook
    Dim getR As range
    Dim lineRNum As Integer
    Dim WriteLine As Integer
    
    '実行ファイルをアクティブにする
    ThisWorkbook.Activate
    
    '入力されたファイル分ループ
    For fcnt = 2 To 99
        '空白行になったら抜ける
        If Cells(fcnt, "A").Value = "" Then Exit For
        
        'ファイルパスを取得
        fPath = Cells(fcnt, "A").Value
        If Dir(fPath, vbNormal) = "" Then
            MsgBox "ファイルが存在しません。"
            Exit Sub
        End If
        
        'ファイルが開いていたらエラーとする
        For Each excWB In Workbooks
            If excWB.Path & "\" & excWB.Name = fPath Then
                MsgBox "ファイルを閉じてください。"
                Exit Sub
            End If
        Next
        
        'ファイルオープン
        Workbooks.Open (fPath)
        
        'workbookオブジェクト取得
        Set getWB = ActiveWorkbook
        
        '読み込みセルの行が空白になるまでループ
        For i = 0 To 99
            '空白だったらループを抜ける
            If Cells(READ_START_ROW + i, READ_START_COLUMN).Value = "" Then Exit For
        Next
        
        '読み込む行数を設定
        lineRNum = i
        
        'Rangeオブジェクト取得
        Set getR = range(Cells(READ_START_ROW, READ_START_COLUMN), _
                            Cells((READ_START_ROW - 1) + lineRNum, READ_END_COLUMN))
        '実行ファイルをアクティブにする
        ThisWorkbook.Activate
        
        
        'もし書き込む行が空白の場合(1ファイル目の処理)
        If Cells(WRITE_START_ROW, WRITE_FIRST_COLUMN) = "" Then
            '読み込んだ行数分ループ
            i = 0
            Do While i < lineRNum
                'セルに書き込み
                Cells(WRITE_START_ROW + i, WRITE_FIRST_COLUMN).Value = getR.Cells(i + 1, 1).Value
                Cells(WRITE_START_ROW + i, WRITE_SECOND_COLUMN).Value = getR.Cells(i + 1, 3).Value
                i = i + 1
            Loop
            
        'もし書き込む行が空白ではなかったら(2ファイル以降の処理)
        Else
            '書き込みセルの行が空白になるまでループ
            For i = 0 To 99
                '空白だったらループを抜ける
                If Cells(WRITE_START_ROW + i, WRITE_FIRST_COLUMN).Value = "" Then Exit For
            Next
        
            '書き込む行数を設定
            WriteLine = WRITE_START_ROW + i
            
            '読み込んだ行数分ループ
            i = 0
            Do While i < lineRNum
                'セルに書き込み
                Cells(WriteLine + i, WRITE_FIRST_COLUMN).Value = getR.Cells(i + 1, 1).Value
                Cells(WriteLine + i, WRITE_SECOND_COLUMN).Value = getR.Cells(i + 1, 3).Value
                i = i + 1
            Loop
        End If
        
        '読み込み処理を行ったワークブックをローズ
        getWB.Close
        
    Next
    
    '完了メッセージ
    MsgBox "完了しました。"

End Sub

実行結果です。