VBA 複数のExcelファイルを1つのワークブックに結合する

このチュートリアルでは、VBAで複数のExcelファイルを1つのワークブックに結合する方法を説明します。

VBAを使用して複数のワークブックから1つのワークブックを作成するには、いくつかのステップを踏まなければなりません。

• ソースとなるファイル（ワークブック）を選択する必要があります。
• 保存先のファイルを選択または作成する必要があります。
• ソースとなるファイルから必要なシートを選択する必要があります。
• 保存先のファイルのどこにデータを配置するか、コードに指示する必要があります。

開いている全てのワークブックの全てのシートを、それぞれ個別のシートとして新しいワークブックに結合する

以下のコードでは、情報をコピーする必要があるファイルは、Excelが開いているファイルをループし、保存先ファイルとして新しいワークブックを開きます。 このコードは、個人用マクロワークブックに配置します。

コピー元として使用されるExcelファイルのみが開かれているとします。

Sub CombineMultipleFiles()
On Error GoTo eh
'必要なオブジェクトを保持するための変数を宣言する
   Dim wbDestination As Workbook
   Dim wbSource As Workbook 
   Dim wsSource As Worksheet 
   Dim wb As Workbook
   Dim sh As Worksheet
   Dim strSheetName As String
   Dim strDestName As String
'画面更新をオフにして高速化する
   Application.ScreenUpdating = False
'最初に新しい宛先ワークブックを作成する
   Set wbDestination = Workbooks.Add
'新しいワークブックの名前を取得し、以下のループからそれを除外する
   strDestName = wbDestination.Name
'次に、データを取得するために開いている各ワークブックをループする
'ただし新しいブックとパーソナルマクロのワークブックは除外する
   For Each wb In Application.Workbooks
      If wb.Name <> strDestName And wb.Name <> "PERSONAL.XLSB" Then
         Set wbSource = wb
         For Each sh In wbSource.Worksheets
            sh.Copy After:=Workbooks(strDestName).Sheets(1)
         Next sh
      End If
   Next wb
'ここで、新規ファイルとパーソナルマクロのワークブック以外の開いているファイルをすべて閉じる
   For Each wb In Application.Workbooks
      If wb.Name <> strDestName And wb.Name <> "PERSONAL.XLSB" Then
         wb.Close False
      End If
   Next wb

'保存先のワークブックからSheet1を削除する
   Application.DisplayAlerts = False
   Sheets("Sheet1").Delete
   Application.DisplayAlerts = True
'オブジェクトをクリーンアップしてメモリを解放する
   Set wbDestination = Nothing
   Set wbSource = Nothing
   Set wsSource = Nothing
   Set wb = Nothing
'完了したら画面の更新をオンにする
   Application.ScreenUpdating = False
   Exit Sub
eh:
   MsgBox Err.Description
End Sub

マクロダイアログボックスをクリックすると、Excelの画面からプロシージャを実行することができます。

これで、結合されたファイルが表示されます。

このコードでは、各ファイルをループして、シートを新しいファイルにコピーします。複数のシートを持つファイルがある場合は、何も書かれていないシートも含めて、それらもコピーします。

開いている全てのワークブックの全てのシートを、新しいワークブックの1つのワークシートに結合する

以下の手順は、開いているすべてのワークブックのすべてのシートの情報を、新しく作成されるワークブックの1つのワークシートに結合するものです。 各シートの情報は、ワークシートの最後の行に貼り付けられます。

Sub CombineMultipleSheets()
On Error GoTo eh
'必要なオブジェクトを保持するために変数を宣言する
   Dim wbDestination As Workbook
   Dim wbSource As Workbook
   Dim wsDestination As Worksheet
   Dim wb As Workbook
   Dim sh As Worksheet
   Dim strSheetName As String
   Dim strDestName As String
   Dim iRws As Integer
   Dim iCols As Integer
   Dim totRws As Integer
   Dim strEndRng As String
   Dim rngSource As Range
'画面更新をオフにして高速化する
   Application.ScreenUpdating = False
'まず、新しい保存先ワークブックを作成する
   Set wbDestination = Workbooks.Add
'新しいワークブックの名前を取得し、以下のループからそれを除外する
   strDestName = wbDestination.Name
'次に、データを取得するために開いている各ワークブックをループする
   For Each wb In Application.Workbooks
      If wb.Name <> strDestName And wb.Name <> "PERSONAL.XLSB" Then
         Set wbSource = wb
         For Each sh In wbSource.Worksheets
'シートの行と列の数を取得する
            sh.Activate
            ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Activate
            iRws = ActiveCell.Row
            iCols = ActiveCell.Column
'シートの最後のセルの範囲を設定する
            strEndRng = sh.Cells(iRws, iCols).Address
'コピー元の範囲を設定する
            Set rngSource = sh.Range("A1:" & strEndRng)
'コピー先シートの最終行を検索する
            wbDestination.Activate
            Set wsDestination = ActiveSheet
            wsDestination.Cells.SpecialCells(xlCellTypeLastCell).Select
            totRws = ActiveCell.Row
'データを貼り付けるのに十分な行数があるか確認する
            If totRws + rngSource.Rows.Count > wsDestination.Rows.Count Then
               MsgBox "連結ワークシートにデータを配置するための行数が不足しています。"
               GoTo eh
            End If
'次の行の下に貼り付ける行を追加する
            If totRws <> 1 Then totRws = totRws + 1
            rngSource.Copy Destination:=wsDestination.Range("A" & totRws)
         Next sh
      End If
   Next wb
'必要なファイル以外の開いているファイルをすべて閉じる
   For Each wb In Application.Workbooks
      If wb.Name <> strDestName And wb.Name <> "PERSONAL.XLSB" Then
         wb.CloseのFalse
      End If
   Next wb
'メモリを解放するためにオブジェクトをクリーンアップする
   Set wbDestination = Nothing
   Set wbSource = Nothing
   Set wsDestination = Nothing
   Set rngSource = Nothing
   Set wb = Nothing
'完了したら画面更新をONにする
   Application.ScreenUpdating = False
   Exit Sub
eh:
   MsgBox Err.Description
End Sub

開いている全てのワークブックの全てのシートを、アクティブなワークブックの1つのワークシートに結合する

他のすべての開いているワークブックの情報を、現在作業しているワークブックに取り込みたい場合、以下のコードを使用することができます。

Sub CombineMultipleSheetsToExisting()
   On Error GoTo eh
'必要なオブジェクトを保持するために変数を宣言する
   Dim wbDestination As Workbook
   Dim wbSource As Workbook
   Dim wsDestination As Worksheet 
   Dim wb As Workbook
   Dim sh As Worksheet
   Dim strSheetName As String
   Dim strDestName As String
   Dim iRws As Integer
   Dim iCols As Integer
   Dim totRws As Integer
   Dim rngEnd As String
   Dim rngSource As Range
'保存先ブックにアクティブワークブックオブジェクトを設定する
   Set wbDestination = ActiveWorkbook
'アクティブファイルの名前を取得する
   strDestName = wbDestination.Name
'画面更新をオフにして高速化する
   Application.ScreenUpdating = False
'まず、アクティブなワークブックに新しい保存先ワークシートを作成する
   Application.DisplayAlerts = False
'シートが存在しない場合、次のエラーを再開する
   On Error Resume Next
   ActiveWorkbook.Sheets("Consolidation").Delete
'エラーをリセットして、最後にエラートラップに行くようにする
   On Error GoTo eh
   Application.DisplayAlerts = True
'ワークブックに新しいシートを追加する
   With ActiveWorkbook
      Set wsDestination = .Sheets.Add(After:=.Sheets(.Sheets.Count))
      wsDestination.Name = "統合"
   End With
'今、データを取得するために開いている各ワークブックを介してループする
   For Each wb In Application.Workbooks
      If wb.Name <> strDestName And wb.Name <> "PERSONAL.XLSB" Then
         Set wbSource = wb
         For Each sh In wbSource.Worksheets
'シートの行数を取得する
            sh.Activate
            ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Activate
            iRws = ActiveCell.Row
            iCols = ActiveCell.Column
            rngEnd = sh.Cells(iRws, iCols).Address
            Set rngSource = sh.Range("A1:" & rngEnd)
'保存先シートの最終行を検索する
            wbDestination.Activate
            Set wsDestination = ActiveSheet
            wsDestination.Cells.SpecialCells(xlCellTypeLastCell).Select
            totRws = ActiveCell.Row
'データを貼り付けるのに十分な行数があるか確認する
            If totRws + rngSource.Rows.Count > wsDestination.Rows.Count Then
               MsgBox "連結ワークシートにデータを配置するための行数が不足しています。"
               GoTo eh
            End If
'1行目でない場合、次の行に貼り付ける行を追加する
            If totRws <> 1 Then totRws = totRws + 1
            rngSource.Copy 宛先:=wsDestination.Range("A" & totRws)
         Next sh
      End If
   Next wb
'必要なファイル以外の開いているファイルをすべて閉じる
   For Each wb In Application.Workbooks
      If wb.Name <> strDestName And wb.Name <> "PERSONAL.XLSB" Then
         wb.CloseのFalse
      End If
   Next wb

'オブジェクトをクリーンアップしてメモリを解放する
   Set wbDestination = Nothing
   Set wbSource = Nothing
   Set wsDestination = Nothing
   Set rngSource = Nothing
   Set wb = Nothing
'完了したら画面更新をONにする
   Application.ScreenUpdating = False
   Exit Sub
eh:
   MsgBox Err.Description
End Sub