複数ブックのシートを1つのブックにコピーする｜Excel VBA

ツイート

特定のフォルダにある複数のブックから、特定のシートを1つのブックにコピーして集約します。

次のサンプルは、"C:\Data\Source\"フォルダ内のすべてのExcelブックについて、「報告書」という名前のシートを新規ブックにコピーします。
このとき、集約用ブック内のシート名が重複しないよう、シート名をそのシートのセルA1の値に変更します。

Sub Sample()
    Dim sFile As String
    Dim sWB As Workbook, dWB As Workbook
    Dim dSheetCount As Long
    Dim i As Long
    Const SOURCE_DIR As String = "C:\Data\Source\"
    Const DEST_FILE As String = "C:\Data\AllReports.xls"
    
    Application.ScreenUpdating = False
    
    '指定したフォルダ内にあるブックのファイル名を取得
    sFile = Dir(SOURCE_DIR & "*.xls")
    
    'フォルダ内にブックがなければ終了
    If sFile = "" Then Exit Sub
    
    '集約用ブックを作成
    Set dWB = Workbooks.Add
    
    '集約用ブック作成時のシート数を取得
    dSheetCount = dWB.Worksheets.Count
    
    Do
        'コピー元のブックを開く
        Set sWB = Workbooks.Open(Filename:=SOURCE_DIR & sFile)
        
        'コピー元の「報告書」シートを集約用ブックにコピー
        sWB.Worksheets("報告書").Copy After:=dWB.Worksheets(dSheetCount)
        
        'シート名をセルA1の値に変更
        ActiveSheet.Name = Range("A1").Value
                
        'コピー元ファイルを閉じる
        sWB.Close
        
        '次のブックのファイル名を取得
        sFile = Dir()
    Loop While sFile <> ""
        
    '集約用ブック作成時にあったシートを削除
    Application.DisplayAlerts = False
    For i = dSheetCount To 1 Step -1
        dWB.Worksheets(i).Delete
    Next i
    Application.DisplayAlerts = True
      
    '集約用ブックを保存して閉じる
    dWB.SaveAs Filename:=DEST_FILE
    dWB.Close
    
    Application.ScreenUpdating = False
End Sub