Excelフォームを使ってエクスプローラーが開いているフォルダ下全部の指定した拡張子のファイルを順に開くマクロ

前にアップしたExcelファイルのあるフォルダ下全部のExcelファイルを順に開いて閉じるマクロ。

これにフォームを追加して、特定のフォルダを指定してそれ以下全部検索してファイルを開くマクロに修正します。

順に、

Windowsエクスプローラーで開いているフォルダを取り出す関数GetCurrentFolderToExplorer。複数のエクスプローラーが起動している場合は最初に見つかったエクスプローラーです。戻り値がフォルダのパスです、失敗したらFalseの値です。

Function GetCurrentFolderToExplorer() As String
    Dim shellApp As Object
    Dim windows As Object
    Dim explorer As Object
    Dim window As Object
    
    ' Create Shell object
    Set shellApp = CreateObject("Shell.Application")
    
    ' Get all open windows
    Set windows = shellApp.windows
    
    ' Loop through all open windows
    For Each window In windows
        ' Check if the window is an Explorer window (not Internet Explorer or other types)
        If InStr(1, window.FullName, "explorer.exe", vbTextCompare) > 0 Then
            ' Get the path of the folder
            GetCurrentFolderToExplorer = window.document.folder.Self.Path
            
            Exit Function
        End If
    Next window
    GetCurrentFolderToExplorer = ""
    
End Function

Excelフォーム/UserFormにコンボボックスとコマンドボタンを貼り付けます。

Option Explicit

Private Sub CommandButton1_Click()
    Dim ss As String
    ss = GetCurrentFolderToExplorer　'開いているエクスプローラーのパスをssに入れる
    If "" <> ss Then
        OpenAndCloseAllXLSXFiles ss, Me.ComboBox1.Value
    Else
        MsgBox "エクスプローラーが起動してません"
    End If
End Sub

Private Sub UserForm_Initialize()
    ComboBox1.AddItem ".xlsx"
    ComboBox1.AddItem ".xlsm"
    Me.ComboBox1.Value = Me.ComboBox1.List(0)
End Sub

Sub OpenAndCloseAllXLSXFiles()
    Dim fso As Object
    Dim folderPath As String
    Dim folder As Object
    Dim file As Object

    ' フォルダのパスを指定します
    folderPath = Excel.ThisWorkbook.Path

    ' FileSystemObjectを作成
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' フォルダが存在するか確認
    If Not fso.FolderExists(folderPath) Then
        MsgBox "指定されたフォルダが存在しません。", vbExclamation
        Exit Sub
    End If

    ' フォルダ内のすべてのファイルとサブフォルダを処理
    ProcessFolder fso.GetFolder(folderPath)
    
    MsgBox "全てのファイルが処理されました。", vbInformation
End Sub

Sub ProcessFolder(folder As Object)
    Dim file As Object
    Dim subFolder As Object
    Dim wb As Workbook

    ' フォルダ内のすべてのファイルを処理
    For Each file In folder.Files
        VBA.DoEvents 'マウス操作可能にするの途中で止めれる。、処理中に変な操作厳禁
        If Excel.ThisWorkbook.Path & "\" & Excel.ThisWorkbook.Name <> folder & "\" & file.Name Then   '自分自身ファイルは開かない
            If Right(file.Name, 5) = ".xlsx" Then
                ' xlsxファイルを開く
                On Error Resume Next ' エラーを無視する
                Debug.Print file.Path 'イミディエイトウィンドウへ出力。ディバッグ用
                Set wb = Workbooks.Open(file.Path)
                If Not wb Is Nothing Then
                    Application.Wait Now + TimeValue("0:0:1")'1秒待つ
                    ' ファイルを閉じる
                    wb.Close False
                    Set wb = Nothing
                End If
                On Error GoTo 0 ' エラーハンドリングをリセット
            End If
        End If
    Next file

    ' サブフォルダを再帰的に処理
    For Each subFolder In folder.SubFolders
        ProcessFolder subFolder
    Next subFolder
End Sub

前のSubプロシージャOpenAndCloseAllXLSXFilesに引数folderPathとmyFileを追加、myFile は拡張子を入れます。SubプロシージャProcessFolderの方も引数myFileを追加してます。

Sub OpenAndCloseAllXLSXFiles(folderPath As String, myFile As String)
    Dim fso As Object
    Dim folder As Object
    Dim file As Object

    ' FileSystemObjectを作成
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' フォルダが存在するか確認
    If Not fso.FolderExists(folderPath) Then
        MsgBox "指定されたフォルダが存在しません。", vbExclamation
        Exit Sub
    End If

    ' フォルダ内のすべてのファイルとサブフォルダを処理
    ProcessFolder fso.GetFolder(folderPath), myFile
    
    MsgBox "全てのファイルが処理されました。", vbInformation
End Sub

Sub ProcessFolder(folder As Object, myFile As String)
    Dim file As Object
    Dim subFolder As Object
    Dim wb As Workbook

    Debug.Print folder
    If Dir(folder, vbDirectory) <> "" Then  'フォルダがあるか確認ァイルを処理
　　　　' フォルダ内のすべてのファイルを処理
        For Each file In folder.Files　　
            VBA.DoEvents 'マウス操作可能にするの途中で止めれる。、処理中に変な操作厳禁
            If Excel.ThisWorkbook.Path & "\" & Excel.ThisWorkbook.Name <> folder & "\" & file.Name Then   '自分自身ファイルは開かない
                If Right(file.Name, Len(myFile)) = myFile Then
                    ' xlsxファイルを開く
                    On Error Resume Next ' エラーを無視する
                    Debug.Print file.Path 'イミディエイトウィンドウへ出力。ディバッグ用
                    Set wb = Workbooks.Open(file.Path)
                    If Not wb Is Nothing Then
                        Application.Wait Now + TimeValue("0:0:1") '1秒待つ
                        ' ファイルを閉じる
                        wb.Close False
                        Set wb = Nothing
                    End If
                    On Error GoTo 0 ' エラーハンドリングをリセット
                End If
            End If
        Next file
    ' サブフォルダを再帰的に処理
        For Each subFolder In folder.SubFolders
            ProcessFolder subFolder, myFile
        Next subFolder
    End If
End Sub