【Excel VBA】ファイルを開いてデータを取得する（その２）

Sub selectFolder()
    Dim strFolder As String
    Dim dlg As FileDialog
    
    'フォルダー選択ダイアログを表示
    Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
    ' キャンセルボタンクリック時はそのまま終了
    If dlg.Show = False Then Exit Sub
    'フォルダーのフルパスを変数に格納
    strFolder = dlg.SelectedItems(1)
    'セルに書き出し
    Range("A1").Formula = strFolder
    Set dlg = Nothing
End Sub

'フォルダ内のファイル名を取出して、セルに反映する
Sub GetFileName_Set()
    Dim strFolder   As String  'フォルダー名
    Dim strFilename As String  'ファイル名
    Dim nRange      As Long    '行カウンタ
    Dim strFileType As String  'ファイル形式
    
    strFileType = "*.xls*"  'ファイル形式を指定
    Range("A2:A1000").Clear '書き込むセル範囲を空ける
    strFolder = Range("A1") & "\"  '検索するフォルダー"\"="¥"
    
    strFilename = Dir(strFolder & strFileType) '最初のファイル名
    'ファイルが見つからなくなるまでループしてデータをセットする
    nRange = 2  '2行目からセット
    Do While strFilename <> ""   ' ループを開始します。
        'セルにファイル名をセットする（拡張子付きのまま）
        If strFilename <> "" Then
            Cells(nRange, 1) = strFilename
            nRange = nRange + 1 'カウントアップ
        End If
        strFilename = Dir   '次のファイル名を返す
    Loop
End Sub

'別ブックからデータ取得（複数ファイルの選択可能で処理する）
Sub Open_Files_DataFetch()
    Dim selectFileName As Variant
    Dim OpenFileName As Variant
    Dim xls As New Excel.Application '新規にExcelを起動
    Dim wb As Workbook
    Dim sh As Worksheet
    Dim Mysh As Worksheet
    Dim shData As Variant
    Dim n As Long
    Dim strFolder As String
    
    On Error GoTo ErrHandler
    Set Mysh = ThisWorkbook.ActiveSheet
    With Mysh
        n = 1
        '取得する情報の見出しを列先頭に記入
        .Cells(n, 2).Value = "ファイル名"
        .Cells(n, 3).Value = "シート名"
        .Cells(n, 4).Value = "取得したデータ"
        'ファイル名をセル範囲から取得して配列に格納
        selectFileName = Range(Range("A2"), Range("A2").End(xlDown))
        strFolder = Range("A1").Value & "\"
        '選択されたファイルに対する処理
        If IsArray(selectFileName) Then
    '        On Error Resume Next  '実行時エラー対策
            '全てのファイルに繰り返し処理を行う
            For Each OpenFileName In selectFileName
                OpenFileName = strFolder & OpenFileName
                'ファイル（ブック）をリードオンリーで開く
                Set wb = xls.Workbooks.Open(fileName:=OpenFileName, _
                                            UpdateLinks:=0, ReadOnly:=True)
                'シートはshに
                Set sh = wb.Worksheets(1) 'シート名を指定する場合()内に記述
    '//////////ここに開いた別ブックからデータを取得する処理を入れる//////////
                '開いた別ブックのデータを変数に保存
                shData = sh.Range("A3").Value
                '変数のデータを書き込む
                n = n + 1
                .Cells(n, 1).Value = wb.name    'ファイル名
                .Cells(n, 2).Value = sh.name    'シート名
                .Cells(n, 3).Value = shData     'セルのデータ
    '//////////ここまで開いた別ブックからデータを取得する処理を//////////////
                wb.Close savechanges:=False         '開いたファイルを閉じる
            Next
        Else
            MsgBox ("ファイルの指定がありません！終了します")
            Exit Sub
        End If
    End With
    MsgBox "選択したファイルの処理が終了しました", vbOKOnly + vbInformation, "ファイル一括処理"
    xls.Application.Quit
    Set xls = Nothing
    Exit Sub
ErrHandler:
    MsgBox "「" & OpenFileName & "」の処理中にエラーが発生しました" & vbCrLf & _
                                Err.Description, vbExclamation, "ファイル一括処理"
    xls.Application.Quit
    Set xls = Nothing
End Sub

Sub Test()
    Call selectFolder
    Call GetFileName_Set
    Call Open_Files_DataFetch
End Sub

Sub selectionFolder()
    Dim strFolder As String
    strFolder = getFolder()  'フォルダーの選択関数を呼ぶ
    Range("A1").Value = strFolder
End Sub

'フォルダー選択ダイアログを表示する関数
Function getFolder() As String
    Dim dlg As FileDialog
    Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
    ' キャンセルボタンクリック時
    If dlg.Show = False Then        
        getFolde = ""
        Exit Function
    End If
    ' フォルダーのフルパスをgetFolderに格納
    getFolder = dlg.SelectedItems(1) 
    Set dlg = Nothing    
End Function