設定シートの情報で繰り返しブックを開き値編集しつつ新規ブック作成するひな形

繰り返し処理でブック新規作成.vba

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 '新規ワークブックを作成

    '１シートづつ繰り返し処理する
    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