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

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

    '選択可能ファイルのフィルターを設定
    Const C_FILEFILTER As String = "Excelファイル,*.xlsx;*.xls"

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

    'ファイルの選択
    Dim varFilesName As Variant
    varFilesName = Application.GetOpenFilename(C_FILEFILTER, , _
                                               "ファイルを複数選択してください", , _
                                               True)
    
    'キャンセルを選択した場合は終了
    If VarType(varFilesName) = vbBoolean Then Exit Sub

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

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

    '統合用新規ブックを作成
    Dim NWB As Workbook
    Set NWB = Workbooks.Add

    On Error Resume Next

    Dim varName       As Variant
    Dim AWB           As Workbook
    Dim CWB           As Workbook
    Dim Sh            As Worksheet
    Dim strErrFiles() As String
    Dim lngErrCount   As Long
    Dim lngCount      As Long

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

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

            '開いたファイルを閉じる
            AWB.Close False

            'エラー確認
            If Err.Number = 0 Then
                lngCount = lngCount + 1
            Else
                Err.Clear
                ReDim Preserve strErrFiles(lngErrCount)
                strErrFiles(lngErrCount) = varName
                lngErrCount = lngErrCount + 1
            End If
        End If
    Next
    
    '統合ブックの1枚目のシートを削除
    If 1 < NWB.Worksheets.Count Then NWB.Worksheets(1).Delete

    On Error GoTo 0

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

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

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