Excel VBA：複数のフォルダを選択

Question

現在、Excelでフォルダをチェックし、いくつかの書式設定の調整（列の追加など）を実行するマクロがあります。

問題は、1つのフォルダを選択してそこにチェックインできるということです。同じディレクトリ内にすべてが存在することを確認するために必要なフォルダがたくさんあります。

AllowMultiSelectをTrueに調整しても、チェックインするフォルダを複数選択することはできません。このコードを変更して、ディレクトリ内のすべてのフォルダを選択できるようにするにはどうすればよいですか？

Sub Button1_Click() 

Dim wb As Workbook 
Dim myPath As String 
Dim myFile As String 
Dim myExtension As String 
Dim FldrPicker As FileDialog 


    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker) 

    With FldrPicker 
     .Title = "Select A Target Folder" 
     .AllowMultiSelect = False 
     If .Show <> -1 Then GoTo NextCode 
     myPath = .SelectedItems(1) & "\" 
    End With 

    NextCode: 
    myPath = myPath 
    If myPath = "" Then GoTo ResetSettings 

    myExtension = "*.xls" 

    myFile = Dir(myPath & myExtension) 

    Do While myFile <> "" 
     Set wb = Workbooks.Open(fileName:=myPath & myFile) 

     DoEvents 

     'Formatting adjustments etc go here 

     wb.Close SaveChanges:=True 

     DoEvents 

     myFile = Dir 

    Loop 

    MsgBox "Complete." 



End Sub 

Answer 1

私は手動ですべてのフォルダを選択するよりも良い解決策を思いつきます。あなたは、すべてのファイルがいくつかのディレクトリにあり、内部にいくつかのサブフォルダがあると言っています。以下のコードでは、選択したフォルダ内のすべてのファイルをループします。フォーマッティング・ロジックには、すべてのフォーマッティング・ロジックを保存します。

Sub Button1_Click() 
Dim objFolder As Object 
Dim objFile As Object 
Dim objFSO As Object 
Dim MyPath As String 
Dim myExtension As String 
Dim FldrPicker As FileDialog 

    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker) 

    With FldrPicker 
     .Title = "Select A Target Folder" 
     .AllowMultiSelect = False 
     If .Show <> -1 Then GoTo NextCode 
     MyPath = .SelectedItems(1) 
    End With 


    Set objFSO = CreateObject("Scripting.FileSystemObject") 
    Call GetAllFiles(MyPath, objFSO) 
    Call GetAllFolders(MyPath, objFSO) 

    MsgBox "Complete." 

NextCode: 
End Sub 
Sub GetAllFiles(ByVal strPath As String, ByRef objFSO As Object) 
Dim objFolder As Object 
Dim objFile As Object 

    Set objFolder = objFSO.GetFolder(strPath) 
    For Each objFile In objFolder.Files 
      Formatting (objFile.Path) 
    Next objFile 
End Sub 

Sub GetAllFolders(ByVal strFolder As String, ByRef objFSO As Object) 
Dim objFolder As Object 
Dim objSubFolder As Object 

    Set objFolder = objFSO.GetFolder(strFolder) 
    For Each objSubFolder In objFolder.subfolders 
     Call GetAllFiles(objSubFolder.Path, objFSO) 
     Call GetAllFolders(objSubFolder.Path, objFSO) 
    Next objSubFolder 
End Sub 

Sub Formatting(strFile As String) 
Dim wb As Workbook 
    If Right(strFile, 3) = "xls" Then 
     Set wb = Workbooks.Open(Filename:=MyPath & myFile) 
     DoEvents 

     'Formatting adjustments etc go here 

     wb.Close SaveChanges:=True 
     DoEvents 
     myFile = Dir 
    End If 
End Sub 

Answer 2

このコンセプトはどうですか？すべてのフォルダ内のすべてのファイルに再帰的にマップし、フォルダ構造全体のスキーマを作成します。次に、各フォルダパスに基づいて各ファイルを制御します。

Option Explicit 

Sub ListAllFiles() 
     searchForFiles "C:\your_path_here\", "writefilestosheet", "*.*", True, True 
    End Sub 

    Sub processOneFile(ByVal aFilename As String) 
     Debug.Print aFilename 
    End Sub 

    Sub writeFilesToSheet(ByVal aFilename As String) 
     With ActiveSheet 
     .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Value = aFilename 
      End With 
    End Sub 


    Private Sub processFiles(ByVal DirToSearch As String, _ 
       ByVal ProcToCall As String, _ 
       ByVal FileTypeToFind As String) 
      Dim aFile As String 
      aFile = Dir(DirToSearch & FileTypeToFind) 
      Do While aFile <> "" 
       Application.Run ProcToCall, DirToSearch & aFile 
       aFile = Dir() 
       Loop 
    End Sub 

    Private Sub processSubFolders(ByVal DirToSearch As String, _ 
       ByVal ProcToCall As String, _ 
       ByVal FileTypeToFind As String, _ 
       ByVal SearchSubDir As Boolean, _ 
       ByVal FilesFirst As Boolean) 

    Dim aFolder As String, SubFolders() As String 

    ReDim SubFolders(0) 

    aFolder = Dir(DirToSearch, vbDirectory) 

     Do While aFolder <> "" 

      If aFolder <> "." And aFolder <> ".." Then 

       If (GetAttr(DirToSearch & aFolder) And vbDirectory) _ 
         = vbDirectory Then 
        SubFolders(UBound(SubFolders)) = aFolder 
        ReDim Preserve SubFolders(UBound(SubFolders) + 1) 
        End If 
        End If 
       aFolder = Dir() 
       Loop 

      If UBound(SubFolders) <> LBound(SubFolders) Then 
       Dim i As Long 
       For i = LBound(SubFolders) To UBound(SubFolders) - 1 
        searchForFiles _ 
         DirToSearch & SubFolders(i), _ 
         ProcToCall, FileTypeToFind, SearchSubDir, FilesFirst 
        Next i 
       End If 

     End Sub 

    Sub searchForFiles(ByVal DirToSearch As String, ByVal ProcToCall As String, _ 
      Optional ByVal FileTypeToFind As String = "*.*", _ 
      Optional ByVal SearchSubDir As Boolean = False, _ 
      Optional ByVal FilesFirst As Boolean = False) 
     On Error GoTo ErrXIT 
     If Right(DirToSearch, 1) <> Application.PathSeparator Then _ 
      DirToSearch = DirToSearch & Application.PathSeparator 

    If FilesFirst Then processFiles DirToSearch, ProcToCall, FileTypeToFind 
    If SearchSubDir Then processSubFolders DirToSearch, ProcToCall, _ 
     FileTypeToFind, SearchSubDir, FilesFirst 

     If Not FilesFirst Then _ 
      processFiles DirToSearch, ProcToCall, FileTypeToFind 
     Exit Sub 
    ErrXIT: 
     MsgBox "Fatal error: " & Err.Description & " (Code=" & Err.Number & ")" 
     Exit Sub 
    End Sub