Excel vbaで、一行ずつコピーし連続保存する

質問

Excel vbaで、一行ずつ別シートにコピーして、そのシートを連続で保存したいです。

まず、Excelで、「全員データ」シートと、「個人別データ」シートを作りまして、
「全員データ」シートのA2からA4までは氏名、B2からC4までは任意の数字等を入力しています。

その状態で、「全員データ」シートに保存したデータを、一人分ずつ「個人別データ」シートにコピーし、 その「個人別シート」を連続で保存する、という作業をしたいと思っています。

ちなみに下記コードでうまくできました。
（セルの値を使ったファイル名の作成も併せて行えました。）

そこからさらに、「個人別データ」シートから単純に（=個人別データ!A2というように）リンクさせた「印刷用シート」を同様に連続で保存する、という作業までしたかったのですが、
その場合に、(1)ファイル名の作成は２行目から４行目のものを使ってうまくいくのですが、(2)そのファイルの中身が全て４行目（最終行）のものになってしまいます。

いろいろ試してみたのですが、解決できませんでした。
付け焼刃程度の知識しかなく、お聞きするのに必要なだけの情報を記載できたかもわかっていません。
情報不足であれば、そこもご教示いただければ助かります。
よろしくお願いします。

Sub 保存()
'
' 保存 Macro
'
'変数を定義
Dim 保存先 As String
Dim 最終行 As Long
Dim 該当行 As Long

保存先 = ThisWorkbook.Path & "\個人別フォーム"
最終行 = Worksheets("全員データ").UsedRange.Rows.Count

'ループ
For 該当行 = 2 To 最終行

'一行ずつコピー
Sheets("全員データ").Select
Range(Cells(該当行, 1), Cells(該当行, 3)).Select
Selection.Copy

'「個人別データ」シートに貼り付ける
Sheets("個人別データ").Select
Range("a2:c2").Select
ActiveSheet.Paste

'「個人別データ」シートを名前を付けて保存
Sheets("個人別データ").Select ’⇒「個人別データ」ではなく「印刷用データ」としたい。
Sheets("個人別データ").Copy ’⇒「個人別データ」ではなく「印刷用データ」としたい。
ActiveWorkbook.SaveAs _
Filename:=保存先 & "\個人別データ" & Range("A2") & Range("B2") & Range("C2") & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close

Next 該当行

End Sub

回答No.1

OrangeCup150 · ベストアンサー

テンプレートファイルを作って流し込みした方がいいと思います。下記のような。

■ファイル
Book1.xlsx　（下の保存マクロとマスタデータ（全員データシート）があること）
テンプレート.xlsx　（個人別シートがあること、個人別データシートを参照した印刷シートも用意できる。 Book1.xlsx と同じフォルダにあること。）

■マクロ
Sub 保存()
Dim テンプレート As String
Dim 保存先 As String
Dim 最終行 As Long
Dim 該当行 As Long

' 設定変数
テンプレート = ThisWorkbook.Path & "\テンプレート.xlsx"
保存先 = ThisWorkbook.Path & "\個人別フォーム"
最終行 = Worksheets("全員データ").UsedRange.Rows.Count
該当行 = 2 ' 処理対象の開始行を設定

' 以下、主処理
Application.ScreenUpdating = False ' 画面更新を抑制
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")

' テンプレートファイルの存在チェック
If Not fso.FileExists(テンプレート) Then
Set fso = Nothing
MsgBox "テンプレートファイルが見つかりません。処理を中止します。" & テンプレート & "を作成してください。", Title:="エラー"
Exit Sub
End If
' 保存先フォルダの存在チェック
If Not fso.FolderExists(保存先) Then
fso.CreateFolder (保存先)
End If

Dim ms As Worksheet ' マスタSheet
Dim tb As Workbook ' テンプレートBook
Dim ts As Worksheet ' テンプレートSheet
Set ms = ThisWorkbook.Worksheets("全員データ") ' このシート名も設定変数にしておいたほうがいい
While 該当行 <= 最終行
Set tb = Workbooks.Add(テンプレート)
Set ts = tb.Worksheets("個人別データ") ' このシート名も設定変数にしておいたほうがいい(2)

ts.Range("a2:c2").Value = ms.Range(ms.Cells(該当行, 1), ms.Cells(該当行, 3)).Value
Dim filename As String
filename = 保存先 & "\個人別データ" & ts.Range("A2") & ts.Range("B2") & ts.Range("C2") & ".xlsx"
If fso.FileExists(filename) Then
' ファイルがすでに在ったら（とりあえず）削除。（結果として上書き）
fso.DeleteFile filename
' ヒント　ここで、ファイル名を別名にすることもできます。
End If
tb.SaveAs filename:=filename, FileFormat:=xlOpenXMLWorkbook
tb.Close
' 処理状況をステータスバーに表示
' 注意　件数ではなく行番号です。（まぎらわしいかも）
Application.StatusBar = "(" & 該当行 & "/" & 最終行 & ")" & filename & "を保存しました。"
Set tb = Nothing

該当行 = 該当行 + 1
Wend

MsgBox "保存処理が終了しました"

Application.StatusBar = False
Application.ScreenUpdating = True
Set fso = Nothing
End Sub

お礼

とてもご丁寧な回答、ありがとうございました。
まだまだ勉強を始めたばかりであり、理解するのに時間がかかるため、
まずは一つ一つしっかり確認して、試させていただきたいと思います。

一人で路頭に迷っていたところなので、とても助かります。
ありがとうございました。