フォルダ内にある複数のエクセルファイルを１つのファイルにシート別にマージする

とある仕事で大量のファイルを１つのブックにまとめる作業があったたのでマクロをつくりました。

できることとしてはこんな感じ。

マージしたいファイル群

• 一つのフォルダに複数のエクセルファイルがある
• そのファイルは「シート１」「シート２」「シート３」、、、といった形で共通のフォーマット
• 中には、歯抜けで「シート１」「シート３」となっている場合もある
• シートの中に図形など入っている（マクロ内で消す）

集約されたファイル

• エクセルファイルのシートは上と同じで「シート１」「シート２」「シート３」、、、といった形にする
• マージしたいファイルがシート毎に追記で書かれていく

マクロ

Sub marge()

    Dim sFile As String
    Dim sWB As Workbook, dWB As Workbook
    Dim dSheetCount As Long
    Const SOURCE_DIR As String = "マージ対象のファイルが入っているフォルダ"
    Const DEST_FILE As String = "出力先ファイルのフルパス"
    
    'シートの数だけ定義
    Dim arrSheet(3) As String
    arrSheet(1) = "シート名1"
    arrSheet(2) = "シート名2"
    arrSheet(3) = "シート名3"
    
    'シートのコピーしたい最初の行番号
    Dim arrStartLine(3) As Integer
    arrStartLine(1) = 8
    arrStartLine(2) = 13
    arrStartLine(3) = 11
    
　　'ダイアログを表示させない
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
                        
　　'集約ファイルのオープン
    Set sumWB = Workbooks.Open(Filename:=DEST_FILE)
    
    Dim i As Integer
       
　　'エラーカウント用
    errCnt = 0    
    
　　'シート数分ループ
    For i = 1 To 3 Step 1
    
        SHEET_NAME = arrSheet(i)

　　　　'エラー記録ファイルのフルパス
        ERROR_FILE = "C:\Data\" & SHEET_NAME & "_error.txt"
        
        
        On Error Resume Next

　　　　'集約ファイルのコピー先シート名
        Set sumWS = sumWB.Worksheets(SHEET_NAME)
         
        '指定したフォルダ内にあるブックのファイル名を取得
        sFile = Dir(SOURCE_DIR & "*.xlsx")
        
        Do
            'コピー元のブックを開く
            Set newWB = Workbooks.Open(Filename:=SOURCE_DIR & sFile)
            'コピー元のブックのシートを指定
            Set newWS = newWB.Worksheets(SHEET_NAME)
            

            'コピー元ブックのシートの歯抜けエラーチェック
            If Err.Number <> 0 Then
                Open ERROR_FILE For Append As #1
                    Print #1, sFile & "エラー:" & Err.Number & " 説明:" & Err.Description
                Close #1
                errCnt = errCnt + 1
            Else
                
　　            'コピー元の現在処理中のファイル名を集約ファイルの該当シート内に記載
                tMaxRow = sumWS.Range("A65536").End(xlUp).Row + 1                
                With sumWS
                     .Cells(tMaxRow, 1) = sFile
                End With
                

　　            'コピー元の現在処理中のシートの最後の行番号を取得
                nMaxRow = newWS.Range("A65536").End(xlUp).Row

　　            'コピー元の現在処理中のファイルの最後の列番号（めんどくさいから取り合ず大きい数字を指定）
                nMaxCol = 20
                

　　            'コピー元の現在処理中のシート内に図形が入ってるのでコピーの時に図形は対象外になるよう図形を削除
                Dim shp As Shape

                For Each shp In newWS.Shapes
                    shp.Delete
                Next shp
  
　　            'コピー元の現在処理中のシート内の対象データをコピー
                With newWS
                    .Range(.Cells(arrStartLine(i), 1), .Cells(nMaxRow, nMaxCol)).Copy
                End With
                
　　            '集約ファイルの該当シートの最後の行＋1で貼り付け先の行を指定
                tMaxRow = tMaxRow + 1
                
　　　　　　　　'貼り付け
                With sumWS
                    .Paste Destination:=Range(.Cells(tMaxRow, 1), .Cells(tMaxRow, 1))
                End With
                        
            End If
            
            'コピー元ファイルを閉じる
            newWB.Close
        
            '次のブックのファイル名を取得
            sFile = Dir()
                
        Loop While sFile <> ""
            
    Next
    
    Application.ScreenUpdating = False
    
    If errCnt > 0 Then
        MsgBox "一部のファイルでエラーが発生しました"
    Else
        MsgBox "終了しました"
    End If
    
    
End Sub