【Excel】複数のエクセル(ブック)のシートを一つのブックに結合するVBA

複数のエクセルのシートを一つのエクセルにまとめるVBAを作ってみた。

ソースコードは使い方の下

使い方

１．まとめたいエクセルを一つのフォルダへ集める

「*.xls*」で検索するので、エクセルファイル以外のファイルがあっても問題なし。

２．VBAの実行

３．対象フォルダの選択

４．選択した対象フォルダ内に「【結合】エクセル.xlsx」が作成される

「【結合】エクセル.xlsx」に「結合元エクセル名.シート名」として、各シートができる。

ソースコード

Option Explicit
'#############################################################################
' Main
'#############################################################################
Sub Main()

    '画面表示OFF
    Application.ScreenUpdating = False

    '-------------------------------------------
    ' 変数定義
    '-------------------------------------------
    Const cnsDIR = "\*.xls*"                '対象フォルダ内エクセルファイル検索用
    Dim FilePath As String                  'ファイルパス
    Dim strFileName As String               '結合元ファイル名
    
    Dim i As Integer                        'ループ用
    
    'シート結合エクセル用オブジェクト
    Dim App As Excel.Application
    Dim Book As Workbook
    Dim Sheet As Worksheet
    'シート結合エクセル保存名
    Dim BookName As String
    
    '結合元エクセル用
    Dim Book2 As Workbook
    Dim Sheet2 As Worksheet
    
    '-------------------------------------------
    ' シート結合後のファイル名の指定
    '-------------------------------------------
    BookName = "【結合】エクセル.xlsx"
    
    '-------------------------------------------
    ' 結合元のフォルダ選択
    '-------------------------------------------
    FilePath = FolderSelect()
    
    'キャンセル時
    If FilePath = "" Then
        MsgBox "処理キャンセル"
        End
    End If
    
    '-------------------------------------------
    ' 結合先ワークブック作成
    '-------------------------------------------
    'オブジェクトセット
    Set App = CreateObject("Excel.Application")
    '非表示
    App.Visible = False
    'エクセル新規オープン
    Set Book = App.Workbooks.Add
    
    '-------------------------------------------
    ' 結合先ワークブックにコピー
    '-------------------------------------------
    ' 先頭のファイル名の取得
    strFileName = Dir(FilePath & cnsDIR, vbNormal)
    
    ' ファイルが見つからなくなるまで繰り返す
    Do While strFileName <> ""
    
        '対象フォルダ配下のエクセルオープン
        Set Book2 = App.Workbooks.Open(Filename:=FilePath & "\" & strFileName)
        
        '開いたコピー元のエクセルのシート分繰り返す
        For i = 1 To Book2.Worksheets.Count
        
            '結合用のブックにシートコピー
            Book2.Worksheets(i).Copy after:=Book.Worksheets(i)
            'シート名を「元のエクセル名.元のシート名」に変更
            Book.ActiveSheet.Name = Book2.Name & "." & Book2.Worksheets(i).Name
        
        Next i
        
        'コピー元のエクセルを保存せずに閉じる
        Book2.Close (False)
        ' 次のファイル名を取得
        strFileName = Dir()
        
    Loop
    
    '-------------------------------------------
    ' 結合したエクセルの終了
    '-------------------------------------------
    '名前を付けて保存
    Book.SaveAs Filename:=FilePath & "\" & BookName
    'エクセルを閉じる
    Book.Close (False)

    '-------------------------------------------
    ' 終了処理
    '-------------------------------------------
    Set Sheet2 = Nothing
    Set Book2 = Nothing

    Set Sheet = Nothing
    Set Book = Nothing
    Set App = Nothing

    MsgBox "処理終了"

    '画面表示ON
    Application.ScreenUpdating = False

End Sub

'#############################################################################
' フォルダ参照用
'#############################################################################
Function FolderSelect() As String

    '-------------------------------------------
    ' 変数定義
    '-------------------------------------------
    Dim objFileDialog As Object             'FileDialog
    Dim strTitle As String                  'タイトル
    Dim strPath As String                   'フォルダパス
    Dim strInitialPath As String            '初期フォルダパス
    
    '-------------------------------------------
    ' フォルダ選択ダイアログの初期設定
    '-------------------------------------------
    'ダイアログタイトル
    strTitle = "結合元のフォルダを選択してください"
    'ダイアログの初期パスをモジュール起動エクセルに設定
    strInitialPath = ActiveWorkbook.Path
    
    '-------------------------------------------
    ' フォルダ選択ダイアログ表示
    '-------------------------------------------
    Set objFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
        
    With objFileDialog
        'タイトル
        .Title = strTitle
        '初期フォルダパス
        .InitialFileName = strInitialPath
        
        If .Show = False Then
            'キャンセル時
            GoTo Exit_Function
        Else
            'フォルダパス取得
            strPath = .SelectedItems(1)
        End If
    
    End With
    
    '-------------------------------------------
    ' 終了処理
    '-------------------------------------------
Exit_Function:
    Set objFileDialog = Nothing
    
    FolderSelect = strPath

End Function