Excelで複数のBookの複数のシートから一つのシートにデータを集約

'*******************************************************************************
'   フォルダを指定すると、フォルダ内のエクセルファイルを開いて、
'　 任意のシート数の任意の箇所から値を取得して一つのシートにまとめるマクロ
'*******************************************************************************
Option Explicit

''
'取得したい内容に応じて随時変更して欲しい項目たち
''
    '貼り付け元のデータの取得開始行数、列数
    Public Const STARTROWCOUNT = 9
    Public Const STARTCOLCOUNT = 3
    
    '貼り付け元のデータの取得終了列数(取得終了行数は次の取得開始列数のデータが
    '無かったら取得終了する仕様です)
    Public Const MAXCOLCOUNT = 10
    
    'シート数(各Book内で抽出したいシート)
    Public Const MAXWATCHSHEETCOUNT = 3
    
    'SHEETNAME_NG_WORD-データを取得したく無いシート名に含まれる名前を逐次追加
    
    'それぞれのシートからコピーしたデータを集約するシート名
    Public Const PASTESHEETNAME = "集約テスト"

''
'変更不要
''
    'データを取得したく無いシート名に含まれる名前を指定
    Public SHEETNAME_NG_WORD As Variant
    
    '集約用シート行数
    Public NOWWRITEROWCOUNT As Integer
    Public NOWWRITECOLCOUNT 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 CopyExcelData()
    Dim CPath As String
    Dim F As Object
    Dim i As Integer

    SHEETNAME_NG_WORD = Array("参考", "old_")
    
    NOWWRITEROWCOUNT = 9
    NOWWRITECOLCOUNT = 3
    
    CPath = FolderSelect()
    
    If CPath = "" Then Exit Sub
    
    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 CopyExcelDataForLoop(CPath, F.Name)
        End If
    Next
    
    Application.ScreenUpdating = True

    MsgBox "終了"
End Sub


'*******************************************************************************
'   エクセルデータコピー関数(ループ処理用)
'*******************************************************************************
Function CopyExcelDataForLoop(xPath As String, xName As String) ', F As Long)
    Dim S As Object
    Dim xlsWkb As Object
    Dim isExcelCopy As Boolean
    Dim i As Integer
    
    'ファイルを開く
    Set xlsWkb = Workbooks.Open(xPath & "\" & xName)
    
    'ファイル内のBook名とシート名を取得して書き込み
    For Each S In xlsWkb.Sheets
    
        isExcelCopy = True
        
        For i = 0 To UBound(SHEETNAME_NG_WORD) - LBound(SHEETNAME_NG_WORD)
            If InStr(S.Name, SHEETNAME_NG_WORD(i)) > 0 Then
                isExcelCopy = False
            End If
        Next
        
        If isExcelCopy = True Then
            Call CopyExcelDataImp(S, xName, S.Name)
        End If
        
    Next
    
    xlsWkb.Close:
    Set xlsWkb = Nothing
End Function

'*******************************************************************************
'   エクセルデータコピー関数(実体)
'*******************************************************************************
Sub CopyExcelDataImp(strWorkSheet As Worksheet, strBookName As String, strSheetName As String)
    Dim sourceRange As Range
    Dim destRange As Range
    Dim sourceAddress As String
    Dim destAddress As String
    Dim addressTable As Worksheet
    Dim i As Long
    Dim j As Long
    Dim iColumnLength As Integer
   
    For i = STARTROWCOUNT To 65536
        'クリップボードにBook名をコピー、ペースト処理
        Set destRange = ThisWorkbook.Sheets(PASTESHEETNAME).Cells(NOWWRITEROWCOUNT, NOWWRITECOLCOUNT)
        destRange.Value = strBookName
    
        'クリップボードにSheet名をコピー、ペースト処理
        Set destRange = ThisWorkbook.Sheets(PASTESHEETNAME).Cells(NOWWRITEROWCOUNT, NOWWRITECOLCOUNT + 1)
        destRange.Value = strSheetName
    
        'クリップボードに1行分のデータをコピー、ペースト
        strWorkSheet.Range(strWorkSheet.Cells(i, STARTCOLCOUNT), strWorkSheet.Cells(i, STARTCOLCOUNT + MAXCOLCOUNT - 1)).Copy
        Range(ThisWorkbook.Sheets(PASTESHEETNAME).Cells(NOWWRITEROWCOUNT, NOWWRITECOLCOUNT + 2), ThisWorkbook.Sheets(PASTESHEETNAME).Cells(NOWWRITEROWCOUNT, NOWWRITECOLCOUNT + 2 + MAXCOLCOUNT - 1)).PasteSpecial xlPasteValues
   
        '貼り付け先の行数を加算
        NOWWRITEROWCOUNT = NOWWRITEROWCOUNT + 1
        
        '次の行のデータが無かった場合、処理終了させる為の判定
        If IsEmpty(strWorkSheet.Cells(i + 1, STARTCOLCOUNT).Value) Then
            Exit For
        End If
        
        Application.CutCopyMode = False
    Next i
    
       
'    For i = STARTROWCOUNT To 65536
'
'        For j = STARTCOLCOUNT To iColumnLength
'            sourceAddress = addressTable.Cells(i, j).Value
'            'destAddress = addressTable.Cells(NOWWRITEROWCOUNT, NOWWRITECOLCOUNT).Value
'
'            'Set sourceRange = Workbooks("入力.xls").Sheets("入力").Range(sourceAddress)
'            Set destRange = ThisWorkbook.Sheets("反映テスト").Cells(NOWWRITEROWCOUNT, NOWWRITECOLCOUNT)
'            destRange.Value = sourceAddress
'
'            NOWWRITECOLCOUNT = NOWWRITECOLCOUNT + 1
'        Next j
'
'        NOWWRITECOLCOUNT = 1
'        NOWWRITEROWCOUNT = NOWWRITEROWCOUNT + 1
'
'        If IsEmpty(addressTable.Cells(i + 1, STARTCOLCOUNT).Value) Then
'            Exit For
'        End If
'    Next i
End Sub