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

'***************************************************************
'* 複数のブックのワークシートを統合した新規ブックを作成する
'*--------------------------------------------------------------
'* 概要     | 複数のブックの各ワークシートを1つの新規ブックに統合する
'*          | ※選択したファイルが1つの場合は統合の対象外となる
'*          | ※マクロ実行時はマクロを実行するブック以外を閉じること
'*          | ※ファイルの数やサイズによっては処理完了まで時間を要する
'*          | 参考：https://excel.syogyoumujou.com/vba/consolidate_books.html
'* 引数     | なし
'* 戻り値   | なし
'* 作成日   | 2023.06.27
'*--------------------------------------------------------------
'* 改修履歴 | 2026.04.11
'***************************************************************
Public Sub mergeBooksIntoNewWorkbook()

On Error GoTo LBL_ERROR

    '------------------------------
    ' 定数定義
    '------------------------------
    Const FILE_FILTER As String = "Excelファイル,*.xlsx;*.xls"

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

    '------------------------------
    ' ファイルの選択
    '------------------------------
    Dim varFilePaths As Variant
    varFilePaths = Application.GetOpenFilename(FILE_FILTER, , _
                                               "ファイルを複数選択してください", , _
                                               True)

    ' キャンセルを選択した場合は終了
    If VarType(varFilePaths) = vbBoolean Then Exit Sub

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

    '------------------------------
    ' 統合用新規ブックの作成
    '------------------------------
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dim wbkNew        As Workbook
    Dim wbkOpened     As Workbook
    Dim wbkCopy       As Workbook
    Dim wsh           As Worksheet
    Dim varFilePath   As Variant
    Dim strErrFiles() As String
    Dim lngErrCount   As Long
    Dim lngCount      As Long

    Set wbkNew = Workbooks.Add

On Error Resume Next

    '------------------------------
    ' 各ブックのシートを統合
    '------------------------------
    For Each varFilePath In varFilePaths

        ' マクロ実行ファイルは統合処理の対象外
        If varFilePath = ThisWorkbook.FullName Then GoTo LBL_CONTINUE



        ' 選択したファイルを開く
        Set wbkOpened = Workbooks.Open(varFilePath)
        If Err.Number <> 0 Then
            Err.Clear
            ReDim Preserve strErrFiles(lngErrCount)
            strErrFiles(lngErrCount) = varFilePath
            lngErrCount = lngErrCount + 1
            GoTo LBL_CONTINUE
        End If

        ' 各シートを統合用新規ブックに移動
        For Each wsh In wbkOpened.Worksheets
            ' 対象シートをコピーする（新規ブックとしてコピーされる）
            wsh.Copy
            Set wbkCopy = ActiveWorkbook
            ' 統合用新規ブックにコピーしたシートを移動する
            
            wbkCopy.Worksheets(1).Move After:=wbkNew.Worksheets(wbkNew.Worksheets.Count)
            If Err.Number <> 0 Then
                Err.Clear
                ReDim Preserve strErrFiles(lngErrCount)
                strErrFiles(lngErrCount) = varFilePath
                lngErrCount = lngErrCount + 1
            End If
        Next wsh

        ' 開いたファイルを閉じる
        wbkOpened.Close False
        lngCount = lngCount + 1

LBL_CONTINUE:
    Next varFilePath

On Error GoTo LBL_ERROR

    ' 統合ブックの1枚目のシート（初期シート）を削除
    If 1 < wbkNew.Worksheets.Count Then wbkNew.Worksheets(1).Delete

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

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

'------------------------------
' エラー処理
'------------------------------
LBL_ERROR:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "エラー番号：" & Err.Number & vbLf & _
           Err.Description, vbExclamation, "エラーが発生しました"
End Sub