一覧表から一行ごとのデータを別ブックに保存するには？

あまり使用頻度はないかもしれませんが・・・・

（例）
○元になる一覧表のブック（BOOK_1.xls)
１行目：項目　　（A1：一連番号　B1：氏名　　　　C1：住所）
２行目：データ１（A2：1　　　　 B2：山田太郎 C2:東京都）
３行目：データ２（A3：2　　　　 B3：山田次郎　　C3:大阪府）
　　　・
　　　・
以降１０行目まで同様のデータが入っているとします。

上記のファイルから
○あらかじめ決められた単票形式のブック（FORMAT.xls)
　A1：一連番号（文字列）　B1：空白
　A2：氏名（文字列）　　　B2：空白
　A3：住所（文字列）　　　B3：空白
を呼び出し

○BOOK_1.xlsの一行目の項目のデータを
　FORMAT.xlsの　B1　B2　B3　の空白部分にコピーペーストし

○BOOK_1.xlsのA2の一連番号の数字をファイル名として取得
　し"1.xls"として新規保存をする。

○そのあとは１０行目までその作業を繰り返し、1.xlsから10.xls
　というファイルを１０個作成し終了する

以上のようなことが可能でしょうか？

実際は列数は３０程度、行数が１５００行程度あり、１５００ほどの
ファイルができるようになるんですけど・・・。

よろしくおねがいします。


　
　

No.1 ベストアンサー 回答者： izayoi2004 回答日時： 2007/09/12 11:55

こんな感じかな

Sub test1()
Dim cnt As Integer
cnt = 2 ' 一列目手抜き
Do Until (Cells(cnt, 1) = "")
Range("A" & cnt).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:="C:\" & cnt & ".xls" '保存場所
ActiveWindow.Close

cnt = cnt + 1
Loop
End Sub

この回答へのお礼

早速のご回答ありがとうございました。教えていただいたものを参考にして以下のマクロでテストはうまくいきました。これから本番のマクロを組んでみます。
早い回答でとても助かりました。またなにかありましたらよろしくお願いします。


Sub test1()
Dim cnt As Integer
cnt = 2 ' 一列目手抜き
Do Until (Cells(cnt, 1) = "")
Workbooks.Open Filename:="J:\test2\format.xls"

　Windows("Book1.xls").Activate
　Range("A" & cnt).Select
　Application.CutCopyMode = False
　Selection.Copy
　Windows("format.xls").Activate
　Range("B1").Select
　ActiveSheet.Paste

　Windows("Book1.xls").Activate
　Range("B" & cnt).Select
　Application.CutCopyMode = False
　Selection.Copy
　Windows("format.xls").Activate
　Range("B2").Select
　ActiveSheet.Paste

　Windows("Book1.xls").Activate
　Range("C" & cnt).Select
　Application.CutCopyMode = False
　Selection.Copy
　Windows("format.xls").Activate
　Range("B3").Select
　ActiveSheet.Paste

ActiveWorkbook.SaveAs Filename:="j:\test2\" & cnt - 1 & ".xls", FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
ActiveWindow.Close

cnt = cnt + 1
Loop
End Sub

お礼日時：2007/09/12 15:39

No.2 回答者： ka_na_de 回答日時： 2007/09/12 21:49

一例です。

ご参考までに。

Sub test()
　Dim NewSheet As Worksheet, MySheet As Worksheet
　Dim r As Long, LastRow As Long
　Dim myPath As String
　　
　Set MySheet = ThisWorkbook.ActiveSheet
　LastRow = MySheet.Cells(Rows.Count, "A").End(xlUp).Row
　myPath = ThisWorkbook.Path
　
　Application.ScreenUpdating = False
　For r = 2 To LastRow
　　If Dir(myPath & "\" & MySheet.Range("A" & r).Value & ".xls") <> "" Then
　　　　Workbooks.Open myPath & "\" & MySheet.Range("A" & r).Value & ".xls"
　　Else
　　　　Workbooks.Add
　　　　ActiveWorkbook.SaveAs Filename:=MySheet.Range("A" & r).Value & ".xls"
　　End If
　　Set NewSheet = ActiveWorkbook.Sheets(1)
　　NewSheet.Cells.Clear
　　MySheet.Rows(1).Copy
　　NewSheet.Range("A1").PasteSpecial Transpose:=True
　　MySheet.Rows(r).Copy
　　NewSheet.Range("B1").PasteSpecial Transpose:=True
　　Application.CutCopyMode = False
　　Application.DisplayAlerts = False
　　　NewSheet.Parent.Close True
　　Application.DisplayAlerts = True
　Next r
　Application.ScreenUpdating = True
　　
End Sub