前にアップした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
(Visited 4 times, 1 visits today)