Excelで複数のBookの複数のシートを一つのファイルに集約

'*******************************************************************************
'   フォルダを指定すると、フォルダ内のエクセルファイルを開いて、
'  任意のシートをコピーして集約用ファイルにコピーするマクロ
'   (集約用ファイルはダイアログで指定したフォルダの1階層上に作成されます)
'*******************************************************************************
Option Explicit

''
'取得したい内容に応じて随時変更して欲しい項目たち
''
    'SHEETNAME_NG_WORD-データを取得したく無いシート名に含まれる名前を逐次追加
    
    'それぞれのシートのコピーを集約用ファイル名
    Public Const PASTEFILENAME = "AllReports"

''
'変更不要
''
    'データを取得したく無いシート名に含まれる名前を指定
    Public SHEETNAME_NG_WORD As Variant
    
    '現在のシート数
    Public NOWSHEETCOUNT As Integer

'*******************************************************************************
'   フォルダ選択ダイアログにて、コピーしたいEXCELファイルが入っているフォルダを
'  取得する
'*******************************************************************************
Function FolderSelect()
    Dim dlg As FileDialog
    Dim fold_path As String
    
    Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
    
    'キャンセルボタンクリック時にマクロを終了
    If dlg.Show = False Then Exit Function
    
    'フォルダーのフルパスを変数に格納
    fold_path = dlg.SelectedItems(1)
    
    '関数名に対して値を設定すると、戻り値を設定したことになる
    FolderSelect = fold_path
End Function


'*******************************************************************************
'   Main
'*******************************************************************************
Sub CopyExcelSheet()
    Dim CPath As String
    Dim F As Object
    Dim i As Integer
    Dim dWB As Workbook
    Dim strNewFileName As String
    
    SHEETNAME_NG_WORD = Array("参考", "old_")
    
    NOWSHEETCOUNT = 0
       
    '集約用ブックを作成
    Set dWB = Workbooks.Add
    
    CPath = FolderSelect()
    
    If CPath = "" Then Exit Sub
    
    'フォルダが同じだと2回目以降に前に作ったシートの中もコピーしてくるため、
    '一つ上の階層のフォルダに作成
    strNewFileName = ".\" & PASTEFILENAME
    
    Application.ScreenUpdating = False
       
    'フォルダ内のファイルを一つずつ取得
    For Each F In CreateObject("Scripting.FileSystemObject").GetFolder(CPath).Files
        If Right(F.Name, 4) = ".xls" Or Right(F.Name, 5) = ".xlsx" Then
            
            'EXCELファイルの場合は情報取得処理
            Call CopyExcelSheets(dWB, CPath, F.Name)
        End If
    Next
        
    'Excelバージョンによって、ファイルの保存方法を変更
    Application.DisplayAlerts = False
    If Val(Application.Version) < 12 Then
        dWB.SaveAs Filename:=strNewFileName
    Else
        dWB.SaveAs Filename:=strNewFileName, FileFormat:=XlFileFormat.xlExcel8
    End If
    dWB.Close
    
    Application.ScreenUpdating = True
    
    MsgBox "終了"
End Sub


'*******************************************************************************
'   エクセルシートコピー用関数
'*******************************************************************************
Function CopyExcelSheets(dWB As Workbook, xPath As String, xName As String)
    Dim xlsWkb As Object
    Dim isExcelCopy As Boolean
    Dim i As Integer
    Dim Sht As Worksheet

    
    'ファイルを開く
    Set xlsWkb = Workbooks.Open(xPath & "\" & xName)
    
    'ファイルからシートを抽出
    For Each Sht In xlsWkb.Worksheets
    
        isExcelCopy = True
        
        For i = 0 To UBound(SHEETNAME_NG_WORD) - LBound(SHEETNAME_NG_WORD)
            If InStr(Sht.Name, SHEETNAME_NG_WORD(i)) > 0 Then
                'シート名にNGワードが合ったらコピーしない
                isExcelCopy = False
            End If
        Next
        
        If isExcelCopy = True Then
            NOWSHEETCOUNT = NOWSHEETCOUNT + 1
            
            'シートをコピー
            Sht.Copy After:=dWB.Worksheets(dWB.Worksheets.Count)
            
            'ActiveSheet.Cells(1).PasteSpecial Paste:=xlValues
            
            'シート名を重複しない...ハズの値に変更
            ActiveSheet.Name = NOWSHEETCOUNT & Sht.Name
            
            Application.CutCopyMode = False
        End If
        
        
    Next Sht
    
    xlsWkb.Close:
    Set xlsWkb = Nothing
End Function