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

Option Explicit

'---------（設定値）---------------------------
Private Const SHEETNAME_ROW = 6                    '１．取り込むシート名を指定するセルの行番号
Private Const SHEETNAME_COL_NUM = 4                '２．取り込むシート名を指定するセルの列番号

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

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

    On Error GoTo err
        
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Dim baseBook As Workbook
    Set baseBook = ActiveWorkbook
    Dim selBook As Workbook
    Dim baseSheet As Worksheet
    Set baseSheet = ActiveSheet
    Dim tmpSheet As Worksheet

    Dim tgtSheetNm As String
    Dim filePathArr As Variant
    Dim filePath As Variant
    Dim fileName As String
    
    Dim importCnt As Long
    Dim msg As String
    
    '指定された「取り込むシート名」を取得する
    tgtSheetNm = baseSheet.Cells(SHEETNAME_ROW, SHEETNAME_COL_NUM).Value

    'ダイアログの表示処理
    filePathArr = Application.GetOpenFilename(Filefilter:="Microsoft Excelブック,*.xls?,csvファイル,*.csv", Title:=Msg3, MultiSelect:=True)

    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
            
                '対象のシートが存在する場合はコピー処理をする
                If tgtSheetNm = "" Or _
                    (tgtSheetNm <> "" And tmpSheet.Name = tgtSheetNm) Or _
                    (tgtSheetNm <> "" And tmpSheet.Name Like tgtSheetNm) Then
                    selBook.Worksheets(tmpSheet.Name).Copy After:=baseBook.Worksheets(baseBook.Worksheets.Count)
                    importCnt = importCnt + 1
                End If
            Next
            
            Workbooks(fileName).Close SaveChanges:=False
        Next filePath
    
        If importCnt = 0 Then
            msg = Msg4
        End If
        
        If msg = "" Then
            MsgBox Msg1 & vbLf & Msg2 & importCnt & "件"
        Else
            MsgBox msg
        End If
        
    'キャンセルが選択された場合はダイアログを閉じる
    Else
        End
    End If

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