指定条件で複数ファイルからデータ取得。エクセルVBAコード

Sub フォルダー選定()
        With Application.FileDialog(msoFileDialogFolderPicker)
            If .Show = True Then
                Path = .SelectedItems(1)
            Else
                Exit Sub
            End If
        End With
End Sub

Sub データ抽出()
    Dim Fn As String
    Dim mb As Workbook
        Set mb = ThisWorkbook
        Call Module1.フォルダー選定
        i = 3
        Fn = Dir(Path & "\*.xls")
        Do While Fn <> ""
            i = i + 1
            mb.Activate
            Worksheets("抽出リスト").Select
            Cells(i, 1) = Fn
            Fn = Dir()
        Loop
        Worksheets("設定").Select
        MsgBox "全部で" & i - 3 & "個ファイルがありました", _
            vbInformation, "複数エクセルファイルデータ収集"
End Sub

Sub シート選択()
    Dim n As Long
        Workbooks("データ収集.xlsm").Activate
        Erase Sna
        With Worksheets("設定")
            NO = 0
            Arow = .Cells(Rows.Count, 1).End(xlUp).Row
            For n = 4 To Arow
                If .Range("B" & n) = "〇" Then
                    Sna(NO) = .Range("A" & n)
                    NO = NO + 1
                End If
            Next n
            CndN = .Range("D2")
            Cnd = .Range("D3")
            CneN = .Range("E2")
            Cne = .Range("E3")
            CnfN = .Range("F2")
            Cnf = .Range("F3")
            CngN = .Range("G2")
            Cng = .Range("G3")
            CnhN = .Range("H2")
            Cnh = .Range("H3")
        End With
End Sub

Sub 各数値取出し()
    Dim ws, wsh As Worksheet
    Dim flg As Boolean
    Dim m, s, k, j As Long
    Dim Fna As String
    Dim Vd, Ve, Vf, Vg, Vh As Variant
    Dim Flag As Boolean
    Application.ScreenUpdating = False
        Call Module1.データ抽出
        Call Module1.シート選択
        Result = 1
            If Sna(0) = "" Then
                Result = 0
            End If
            For m = 4 To 8
                If Cells(3, m) <> "" Then
                    Exit For
                Else
                    Result = 0
                End If
            Next m
        If Result = 0 Then
            MsgBox "抽出対象のシートまたはセルが選択されていません", _
            vbInformation, "複数エクセルファイルデータ収集"
            Exit Sub
        End If
        On Error Resume Next
        Workbooks("データ収集.xlsm").Activate
        With Worksheets("抽出リスト")
            .Range("B1") = "シート名"
            .Range("A3") = "ファイル名"
            .Range("B3") = "チェック欄"
        End With
        For s = 4 To i
            Workbooks("データ収集.xlsm").Activate
            With Worksheets("抽出リスト")
                Fna = .Range("A" & s)
            End With
            ChDir Path
            Workbooks.Open Fna
            k = 0
            Flag = False
            For j = 0 To NO - 1
                For Each wsh In Workbooks(Fna).Worksheets
                    If wsh.Name = Sna(j) Then
                        Flag = True
                        Exit For
                    End If
                    Flag = False
                Next wsh
                If Flag = True Then
                    With Worksheets(Sna(j))
                        Vd = .Range(Cnd)
                        Ve = .Range(Cne)
                        Vf = .Range(Cnf)
                        Vg = .Range(Cng)
                        Vh = .Range(Cnh)
                    End With
                    Workbooks("データ収集.xlsm").Activate
                    With Worksheets("抽出リスト")
                        .Range("C1").Offset(, 6 * k) = Sna(j)
                        .Range("C2").Offset(, 6 * k) = "項目名"
                        .Range("C3").Offset(, 6 * k) = "セル番号"
                        .Range("D2").Offset(, 6 * k) = CndN
                        .Range("E2").Offset(, 6 * k) = CneN
                        .Range("F2").Offset(, 6 * k) = CnfN
                        .Range("G2").Offset(, 6 * k) = CngN
                        .Range("H2").Offset(, 6 * k) = CnhN
                        .Range("D3").Offset(, 6 * k) = Cnd
                        .Range("E3").Offset(, 6 * k) = Cne
                        .Range("F3").Offset(, 6 * k) = Cnf
                        .Range("G3").Offset(, 6 * k) = Cng
                        .Range("H3").Offset(, 6 * k) = Cnh
                        .Range("D" & s).Offset(, 6 * k) = Vd
                        .Range("E" & s).Offset(, 6 * k) = Ve
                        .Range("F" & s).Offset(, 6 * k) = Vf
                        .Range("G" & s).Offset(, 6 * k) = Vg
                        .Range("H" & s).Offset(, 6 * k) = Vh
                    End With
                    k = k + 1
                Else
                    k = k + 1
                End If
                Workbooks(Fna).Activate
            Next j
            Workbooks(Fna).Close False
        Next s
        With Worksheets("抽出リスト")
            .Columns.AutoFit
            .Select
        End With
        Application.ScreenUpdating = True
        MsgBox "抽出リストの作成が完了しました", _
            vbInformation, "複数エクセルファイルデータ収集"
End Sub