2つのExcelファイル間でデータ転記させるマクロを作ってみた

はじめに
マクロ
ダウンロード

はじめに

先日、Excelファイルを使用して以下の条件でデータを転記させる作業がありました。条件は以下の通り。

2つのExcelファイル（AとB）があり、AからBにデータを転機する
Aの1行がBの1シートになる
処理させる行は任意に指定したい
ファイル名や転記させるセルは将来変更する可能性あり

文章だとちょっとわかりにくいと思うので、図にしてみます。

条件の3番目と4番目は汎用的に処理できるようにしないと駄目ですね。設定シートを作ってそこに書かれた内容で処理するのが良さそうです。ということで早速、作成してみました。

マクロ

'#######################################################################################
'# 概要：2つのExcelファイル間でデータを転記します。
'# 作成者：ITStudy
'# 作成日：2020/08/28
'#######################################################################################

Sub データ転記()

    Dim FromFile As String
    Dim ToFile As String
    Dim FromStartRow  As String
    Dim FromEndRow   As String
    
    Set ss = ActiveSheet
    FromFile = Range("a2")
    ToFile = Range("b2")
    FromStartRow = Range("e2")
    FromEndRow = Range("f2")
    MaxRow = Range("C1").End(xlDown).Row
    
    'ブックを開く（読み取り専用を推奨するメッセージを非表示）
    Set fb = Workbooks.Open(Filename:=FromFile, ReadOnly:=False, IgnoreReadOnlyRecommended:=True)
    Set tb = Workbooks.Open(Filename:=ToFile)
    
    For i = FromStartRow To FromEndRow
        'シートのコピー
        tb.Worksheets(1).Copy Before:=Worksheets(1)
        'シート名の変更
        ActiveSheet.Name = fb.Worksheets(1).Range("d" & i)
        'データ転記
        For j = 2 To MaxRow
            tb.Worksheets(1).Range(ss.Range("D" & j)) = fb.Worksheets(1).Range((ss.Range("C" & j) & i))
        Next
    Next
    
    '上書き保存
    tb.Save
    'ブックを閉じる
    fb.Close
    tb.Close

End Sub