トップ　>　汎用コード　>　複数のブックを統合

'-------------------------------------------------------------------------------
' 複数のブックのワークシートを統合した新規ブックを作成
'-------------------------------------------------------------------------------
' 複数のブックの各ワークシートを、 1つの新規ブックに統合するマクロです。
' マクロを実行するとファイル選択ダイアログボックスが表示されるので、
' 複数のExcelファイルを選択してください。
' ファイルの選択が1つの場合は、統合の対象外となりますので気をつけてください。
' またマクロを実行するときには、マクロを実行するブック以外は閉じてください。
' ※ 選択したファイルの数やサイズによっては処理完了まで時間を要します
'
'［作成日］2023.06.27　［更新日］　2024.11.27
' https://excel.syogyoumujou.com/vba/consolidate_books.html
'-------------------------------------------------------------------------------
Sub ConsolidateBooks()

    '---------------------------------------
    ' 定数設定
    '---------------------------------------
    ' ダイアログボックス用
    Const L_FILE_FILTER  As String = "Excelファイル,*.xlsx;*.xls"       ' ファイルフィルター
    Const L_FILTER_INDEX As Long = 1                                    ' フィルターインデックス
    Const L_DIALOG_TITLE As String = "複数のファイルを選択してください" ' ダイアログボックスタイトル

    '---------------------------------------
    ' 開いているブック数が2つ以上の場合は終了
    '---------------------------------------
    If 1 < Workbooks.Count Then
        MsgBox "このブック以外のExcelファイルを閉じてください", vbExclamation, "終了します"
        Exit Sub
    End If

    '---------------------------------------
    ' ファイルを選択
    '---------------------------------------
    Dim varFilesName As Variant
    '《ファイル選択ダイアログボックス》
    ' ・ 引数1：ファイルフィルター
    ' ・ 引数2：ファイルインデックス（既定で表示するフィルター文字列の指定）
    ' ・ 引数3：ダイアログボックスタイトル
    ' ・ 引数4：ボタンテキスト（Macintosh用）
    ' ・ 引数5：複数選択の設定（True：複数選択可　False：複数選択不可）
    varFilesName = Application.GetOpenFilename(L_FILE_FILTER, _
                                               L_FILTER_INDEX, _
                                               L_DIALOG_TITLE, _
                                               , _
                                               True)
    
    ' キャンセルを選択した場合は終了
    If VarType(varFilesName) = vbBoolean Then Exit Sub

    ' 選択したファイルが1つの場合は抜ける
    If LBound(varFilesName) = UBound(varFilesName) Then
        MsgBox "複数のファイルを選択してください", vbExclamation, "終了します"
        Exit Sub
    End If

    '---------------------------------------
    ' 統合処理
    '---------------------------------------
On Error Resume Next

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False

    ' 統合用新規ブック作成
    Dim wbkNew As Workbook
    Set wbkNew = Workbooks.Add
    
    ' ワンタイムシート名生成・設定
    Dim strSheetName As String
    strSheetName = "sht" & WorksheetFunction.RandBetween(10000, 99999999)
    wbkNew.Worksheets(1).Name = strSheetName

    Dim var           As Variant
    Dim wbkTarget     As Workbook
    Dim wbkCopy       As Workbook
    Dim shtTarget     As Worksheet
    Dim strErrFiles() As String
    Dim lngErrCount   As Long
    Dim lngCount      As Long

    For Each var In varFilesName
    
        ' 選択ファイルとマクロ実行ファイルが同じ場合は処理を行わない
        If var = ThisWorkbook.FullName Then
            ' マクロ実行ファイル統合処理の対象外
        Else
            ' 選択したファイルを開く
            Set wbkTarget = Workbooks.Open(var)

            For Each shtTarget In wbkTarget.Worksheets
                ' 対象シートをコピー(新規ブックとしてコピーされる)
                shtTarget.Copy
                Set wbkCopy = ActiveWorkbook
                
                ' 統合用新規ブックにコピーしたシートを移動
                wbkCopy.Worksheets(1).Move After:=wbkNew.Worksheets(wbkNew.Worksheets.Count)
            Next

            ' 選択したファイルを閉じる
            wbkTarget.Close SaveChanges:=False

            ' エラー確認
            If Err.Number = 0 Then
                lngCount = lngCount + 1
            Else
                ' エラーの場合は対象ブックパスを配列に代入する
                Err.Clear
                ReDim Preserve strErrFiles(lngErrCount)
                strErrFiles(lngErrCount) = var
                lngErrCount = lngErrCount + 1
            End If
        End If
    Next
    
    ' 統合用新規ブックの初期シート削除
    If 1 < wbkNew.Worksheets.Count Then wbkNew.Worksheets(strSheetName).Delete

    Application.EnableEvents = True
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

On Error GoTo 0

    '---------------------------------------
    ' 終了メッセージ
    '---------------------------------------
    If lngErrCount = 0 Then
        MsgBox "新規ブックに" & lngCount & "つのブックを統合しました", _
               vbInformation, _
               "終了しました"
    Else
        MsgBox "エラーになったファイルがあります" & vbLf & vbLf & Join$(strErrFiles, vbLf), _
               vbExclamation, _
               "終了しました"
    End If
End Sub

【書籍紹介】知りたいがすぐわかる！　やりたいがすぐできる！
「Excel VBA 逆引きで学ぶ ユーザーフォーム&コントロール」（Kindle版）
ユーザーフォームを扱えると、VBAでできることが大きく広がります！
本書では、知りたいこと、やりたいことから、逆引きで学びを深められます。
140以上のサンプルファイル付き！