【知らなくても使える】指定したExcelファイルの複数シートを取得するマクロツール_パート２（Excel VBA）

Option Explicit

'---------（設定値）---------------------------
Private Const SHEETNAME_ROW = 6                                 '１．取込むシート名を指定するセルの行番号
Private Const SHEETNAME_COL_NUM = 4                             '２．取込むシート名を指定するセルの列番号
Private Const SETTING_TABLE_NM = "対象ファイル名とシート名"       '３．取込むファイル名とシート名が記載されたテーブル名
Private Const SETTING_TABLE_ROW = 3                             '４．取込むファイル名とシート名が記載されたテーブルの開始行番号
Private Const SETTING_TABLE_COL_NUM = 1                         '５．取込むファイル名とシート名が記載されたテーブルの開始列番号
Private Const SETTING_SHEET_NM = "setting"                      '６．設定シートの名称

'---------（メッセージ）-----------------------
Private Const Msg1 = "シート取得処理が正常に終了しました。"
Private Const Msg2 = "取込件数："
Private Const Msg3 = "取込むシートがあるExcelファイル等を選択してください。"
Private Const Msg4 = "対象のシートが見つかりませんでした。"
Private Const EMsg1 = "予期せぬエラーが発生しました"
'----------------------------------------------

Dim BaseBook As Workbook
Dim BaseSheet As Worksheet
Dim SettingSht As Worksheet

'===========================================
'対象ファイルを選択した際のメイン処理
'===========================================
Sub 対象ファイル選択_Click()

    On Error GoTo err
        
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Set BaseBook = ActiveWorkbook
    Set BaseSheet = ActiveSheet
    Set SettingSht = Worksheets(SETTING_SHEET_NM)
    Dim selBook As Workbook
    Dim tmpSheet As Worksheet

    Dim filePathArr As Variant
    Dim filePath As Variant
    Dim fileName As String
    
    Dim importCnt As Long

    'ダイアログの表示処理
    filePathArr = Application.GetOpenFilename(Filefilter:="Microsoft Excelブックまたはcsvファイル,*.xls?;*.csv", Title:=Msg3, MultiSelect:=True)
    
    Call Initialize
    
    If IsArray(filePathArr) Then
    
        '配列ぶん繰り返しファイルを開く
        For Each filePath In filePathArr
        
            'ファイル名のみを取得する
            fileName = Dir(filePath)
            Workbooks.Open (filePath), UpdateLinks:=1
            Set selBook = ActiveWorkbook
        
            '対象ファイルの全シートを1つずつループして処理する
            For Each tmpSheet In selBook.Worksheets
                
                SettingSht.Cells(SETTING_TABLE_ROW + importCnt, SETTING_TABLE_COL_NUM).Value = filePath
                SettingSht.Cells(SETTING_TABLE_ROW + importCnt, SETTING_TABLE_COL_NUM + 1).Value = fileName
                SettingSht.Cells(SETTING_TABLE_ROW + importCnt, SETTING_TABLE_COL_NUM + 2).Value = tmpSheet.Name
                SettingSht.Cells(SETTING_TABLE_ROW + importCnt, SETTING_TABLE_COL_NUM + 3).Value = fileName & "：" & tmpSheet.Name
                importCnt = importCnt + 1
                
            Next
            
            Workbooks(fileName).Close SaveChanges:=False
            BaseBook.SlicerCaches(1).ClearManualFilter
            
        Next filePath
        
    'キャンセルが選択された場合はダイアログを閉じる
    Else
        End
    End If

    '最初のシートを選択
    Worksheets(BaseSheet.Name).Select
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
    Exit Sub
err:
    MsgBox EMsg1
    
End Sub

'===========================================
'シート取込を実行した際のメイン処理
'===========================================
Sub シート取込_Click()

    On Error GoTo err
        
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Set BaseBook = ActiveWorkbook
    Set BaseSheet = ActiveSheet
    Set SettingSht = Worksheets(SETTING_SHEET_NM)
    Dim selBook As Workbook
    Dim tgtSheetNm As String
    
    Dim filePath As Variant
    Dim fileName As String
    
    Dim importCnt As Long
    Dim msg As String

    Dim tbl As ListObject
    Dim tblRow As ListRow
    
    ' 対象のテーブルを指定
    Set tbl = SettingSht.ListObjects(SETTING_TABLE_NM) ' テーブル名を変更
        
    ' テーブル内の各行をループ
    For Each tblRow In tbl.ListRows
    
        ' 表示されている行の場合
        If tblRow.Range.EntireRow.Hidden = False Then
            
            filePath = tbl.DataBodyRange.Cells(tblRow.Index, SETTING_TABLE_COL_NUM).Value
            tgtSheetNm = tbl.DataBodyRange.Cells(tblRow.Index, SETTING_TABLE_COL_NUM + 2).Value
            fileName = Dir(filePath)
            
            Workbooks.Open (filePath), UpdateLinks:=1
            Set selBook = ActiveWorkbook

            selBook.Worksheets(tgtSheetNm).Copy After:=BaseBook.Worksheets(BaseBook.Worksheets.Count)
            importCnt = importCnt + 1
        
            Workbooks(fileName).Close SaveChanges:=False
        End If
        
    Next tblRow
    
    If importCnt = 0 Then
        msg = Msg4
    End If
    
    If msg = "" Then
        MsgBox Msg1 & vbLf & Msg2 & importCnt & "件"
    Else
        MsgBox msg
    End If
    
    '最初のシートを選択
    Worksheets(BaseSheet.Name).Select
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
    Exit Sub
err:
    MsgBox EMsg1
End Sub

'-------------------------------------------
'対象のファイル名とシート名が記載されたテーブルの初期化処理
'-------------------------------------------
Sub Initialize()

    With SettingSht.ListObjects(SETTING_TABLE_NM)
        If Not .DataBodyRange Is Nothing Then
        
            'すべての行を削除して初期化
            .DataBodyRange.EntireRow.Delete
            
        End If
    End With
    
End Sub