エクセルでデータ.xlsから１行毎に元シート.xlsへコピーし１行毎に多数ファイルを作成したい。

質問

現在、以下のような繰り返し作業をカット＆ペーストで何度も行わないといけません。
手が疲れて困っています。
エクセルマクロで簡単にできる方法を教えてください。

以下の例のようにデータ.xlsは、一番上の行に元シート.xlsに差込む位置、
次の行から１行ごとのデータがあります。

データ.xls
A B C D E F
1 A2 A3 B3 C2 D2 D3 <- 元シート.xlsにコピーする位置
2 test 123 456 789 012 345
3 test2 456 789 012 345 678
4 test 456 123 789 012 345
...

元シート.xlsは固定文字や罫線等があります。

元シート.xls
A B C D
1 ------------------------------
2
3
4 abcdefg 9876543
5 ------------------------------

元シート.xlsに、データ.xlsの１行ごとのデータを、指定したセルに入れ、
A列の名前で多数のファイルを作成したいのです。
ただし、A列で同じファイル名がある時は、ファイル名の後に_2等を付けて保存したいのです。

以下のような多数のファイルを自動的に作成する方法を教えて下さい。
宜しくお願い致します。

test.xls
------------------------------
test 789 012
123 456 345
abcdefg 9876543
------------------------------

test2.xls
------------------------------
test2 012 345
456 789 678
abcdefg 9876543
------------------------------

test_2.xls
------------------------------
test2 789 012
456 123 345
abcdefg 9876543
------------------------------
...

回答No.1

fujillin · ベストアンサー

丸投げに当るので、原型のみです。
上の例のtest_2.xlsのA1セルはtestが正しいと解釈して作成しています。
その他不明な部分は適当に仮定しています。（原型なので問題ないでしょう。）

・データの整合性等のチェックは一切省いていますので、実際の使用では各種のチェックを入れておかないと即エラーになります。（データが想定と違う場合）
・変数の宣言は省略して名前のみにしてありますが、実際はタイプを指定しておいたほうが良いでしょう。
・元シート.xlsおよび作成されるファイルは同じフォルダにあるものとしています。
・データ.ｘｌｓからのコピーはコピーメソッドで行っていますので、書式などもそのままコピーされます。
　（もし式が入力されている場合は、参照がおかしくなることがあり得ます）
・元データのデータ有無に関わらず、データシートのデータを上書きするようにしています。

データ.ｘｌｓがアクティブな状態で実行されるものと仮定しています。
（シート名、ブック名などは仮設定です）
適宜、修正してご使用ください。

Sub test()
Dim dst_name, mbk_name, mst_name, bk_name, b_name
Dim dst, mbk, mst
Dim ad, p, i, j

p = ThisWorkbook.Path & "\"　　'// 対象となるフォルダのパス+"\"
dst_name = "データシート"　　　　'// 対象データのあるデータ.ｘｌｓのシート名
mbk_name = "元シート.xls"　　　　'// 元シート.ｘｌｓのファイル名
mst_name = "元シート"　　　　　　'// 元シート.ｘｌｓの対象とすべきシート名

Set dst = Sheets(dst_name)
For i = 2 To dst.Cells(dst.Rows.Count, 1).End(xlUp).Row

'// 作成するファイル名をチェック
　b_name = dst.Cells(i, 1)
　If b_name <> "" Then
　　j = 1
　　bk_name = p & b_name & ".xls"
　　While Dir(bk_name) <> ""
　　　j = j + 1
　　　bk_name = p & b_name & "_" & Format(j, "#") & ".xls"
　　Wend

'// データをコピー、保存
　　Workbooks.Open p & mbk_name
　　Set mbk = ActiveWorkbook
　　Set mst = mbk.Sheets(mst_name)
　　For j = 1 To dst.Cells(i, dst.Columns.Count).End(xlToLeft).Column
　　　dst.Cells(i, j).Copy (mst.Range(dst.Cells(1, j).Text))
　　Next j
　　mbk.SaveAs (bk_name)
　　mbk.Close
　End If
Next i
End Sub

お礼

早速の回答ありがとうございます。

記入間違いまで正しく解釈されて、思い通りの答えでした。
これで作業が楽になります。本当に感謝致します。

ありがとうございました。