設定シートの情報で繰り返しブックを開き値編集しつつ新規ブック作成するひな形
Excelの新規ブックを開き、リボンの「開発 > Visual Basic」を開いて開発モジュールを挿入し以下のソースを張り付ける。
以下のソース内に記載しているが新規ブックのシート内に2点記載する。
Sub 複数ブックを元に新規ブックを作成する例() '読み込み開始位置の指定。本VBAを記載するブックのActiveSheetに設定として記載想定。 Dim v読込データブック開始行 As Integer v読込データブック開始行 = 2 Const v読込データブック開始列 As Integer = 1 Const v読込フォーマットブック開始行 As Integer = 2 Const v読込フォーマットブック開始列 As Integer = 2 Dim vファイル名 As String Dim vフォーマットファイル名 As String Dim v対象データブック As Workbook Dim v対象フォーマットブック As Workbook Dim v新規ブック As Workbook Dim v作成シートインデックス As Integer v作成シートインデックス = 1 '以下読み込んだデータブックの定義 Dim vデータ開始行 As Integer vデータ開始行 = 10 Const vデータ開始列 As Integer = 4 '以下作成するシートの定義 Dim v書き込みデータ開始行 As Integer v書き込みデータ開始行 = 17 Dim v書き込みデータ列 As Integer v書き込みデータ列 = 2 Dim v処理開始時間 As Single v処理開始時間 = Timer Debug.Print getNow() & "_処理開始" Application.ScreenUpdating = False '対象のブック指定が空行になるまで繰り返し処理 Do While Cells(v読込データブック開始行, v読込データブック開始列) <> "" vファイル名 = Cells(v読込データブック開始行, v読込データブック開始列) vフォーマットファイル名 = Cells(v読込フォーマットブック開始行, v読込フォーマットブック開始列) '毎回読む必要はないのでDoWhileの外でも問題なし Set v対象データブック = Workbooks.Open(Filename:=vファイル名, ReadOnly:=True, UpdateLinks:=0) Debug.Print getNow() & "_" & v対象データブック.Name Set v対象フォーマットブック = Workbooks.Open(Filename:=vフォーマットファイル名, ReadOnly:=True, UpdateLinks:=0) Debug.Print getNow() & "_" & v対象フォーマットブック.Name '新規ブック作成 Set v新規ブック = Workbooks.Add '新規ワークブックを作成 '1シートづつ繰り返し処理する For Each i In v対象データブック.Sheets ' ======== 以下、編集処理を作りこみます ======== '新規ワークブックのsheet1の前にひな形をコピー v対象フォーマットブック.Worksheets("sample").Copy before:=v新規ブック.Sheets(v新規ブック.Sheets.Count) v新規ブック.Sheets(v作成シートインデックス).Name = i.Name & "登録" 'シート名を変更 Dim rowcount As Integer rowcount = 1 Do If i.Cells(vデータ開始行, vデータ開始列).Value = "" Then Exit Do End If '以下例。要件により列も変数化したり複数列への値設定など変更する 'v新規ブック.Sheets(v作成シートインデックス).Cells(v書き込みデータ開始行, 1) = i.Cells(vデータ開始行, vカラム論理名列).Value 'v新規ブック.Sheets(v作成シートインデックス).Cells(v書き込みデータ開始行, 2) = i.Name vデータ開始行 = vデータ開始行 + 1 v書き込みデータ開始行 = v書き込みデータ開始行 + 1 rowcount = rowcount + 1 Loop '次のシート処理のため制御変数を初期化等する vデータ開始行 = 10 v書き込みデータ開始行 = 17 rowcount = 1 v作成シートインデックス = v作成シートインデックス + 1 Next i ' 余分なSheet1シートを削除 Application.DisplayAlerts = False ' メッセージを非表示 v新規ブック.Sheets("Sheet1").Delete Application.DisplayAlerts = True ' メッセージを表示 v対象データブック.Close SaveChanges:=False v対象フォーマットブック.Close SaveChanges:=False v読込データブック開始行 = v読込データブック開始行 + 1 '複数ブック対応するときは以下をコメントアウト解除 'v作成シートインデックス = 1 Loop '新規ブックの保存処理はないため未保存で終了すると新規作成したブックは破棄されます v新規ブック.Sheets(1).Select Application.ScreenUpdating = True Debug.Print getNow() & "_処理終了。所要時間は" & Round(Timer - v処理開始時間, 1) & "秒" MsgBox getNow() & "_所要時間は" & Round(Timer - v処理開始時間, 1) & "秒_" & "抽出終了。作成シート数:" & (v作成シートインデックス - 1) End Sub '時刻表示 Function getNow() getNow = Format(Date, "yyyy_mm_dd") & "_" & Format(Hour(Time), "00") & ":" & Format(Minute(Time), "00") & ":" & Format(Second(Time), "00") End Function