循環訪問用戶指定的根目錄中的子文件夾和文件

Question

通過單個文件的我的循環腳本工作正常，但我現在需要它也查看/查看多個目錄。我堅持....

事情需要發生的順序：

• 提示用戶選擇他們所需要
• 我需要劇本來尋找那個根的任何文件夾的根目錄目錄
• 如果腳本找到一個，它會打開第一個（所有文件夾，因此沒有針對該文件夾的特定搜索過濾器）
• 一旦打開，我的腳本將遍歷文件夾中的所有文件並執行所需的操作做
• 它的完成後，關閉該文件，關閉該目錄，並移動到下一個，等等。
• 循環，直到所有的文件夾都被打開/掃描

這是我，這不工作，我知道是錯誤的：

MsgBox "Please choose the folder." 
Application.DisplayAlerts = False 
With Application.FileDialog(msoFileDialogFolderPicker) 
    .InitialFileName = "\\blah\test\" 
    .AllowMultiSelect = False 
    If .Show <> -1 Then MsgBox "No folder selected! Exiting script.": Exit Sub 
    CSRootDir = .SelectedItems(1) 
End With 
folderPath = Dir(CSRootDir, "\*") 

Do While Len(folderPath) > 0 
    Debug.Print folderPath 
    fileName = Dir(folderPath & "*.xls") 
    If folderPath <> "False" Then 
     Do While fileName <> "" 
      Application.ScreenUpdating = False 
      Set wbkCS = Workbooks.Open(folderPath & fileName) 

      --file loop scripts here 

     Loop 'back to the Do 
Loop 'back to the Do 

最終代碼。它遍歷每個子目錄中的所有子目錄和文件。

Dim FSO As Object, fld As Object, Fil As Object 
Dim fsoFile As Object 
Dim fsoFol As Object 
Dim fileName As String 

    MsgBox "Please choose the folder." 
    Application.DisplayAlerts = False 
    With Application.FileDialog(msoFileDialogFolderPicker) 
     .InitialFileName = "\\blah\test\" 
     .AllowMultiSelect = False 
     If .Show <> -1 Then MsgBox "No folder selected! Exiting script.": Exit Sub 
     folderPath = .SelectedItems(1) 
    End With 

    If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\" 
     Set FSO = CreateObject("Scripting.FileSystemObject") 
     Set fld = FSO.getfolder(folderPath) 
    If FSO.folderExists(fld) Then 
     For Each fsoFol In FSO.getfolder(folderPath).subfolders 
       For Each fsoFile In fsoFol.Files 
        If Mid(fsoFile.Name, InStrRev(fsoFile.Name, ".") + 1) = "xls" Then 
    fileName = fsoFile.Name 
    Application.ScreenUpdating = False 
    Set wbkCS = Workbooks.Open(fsoFile.Path) 

    'My file handling code 


       End If 
       Next 
     Next 
    End If 

Answer 1

您可能會發現它更容易使用的FileSystemObject，財產以後這樣

這轉儲文件夾/文件列表中Immediate window

Option Explicit 

Sub Demo() 
    Dim fso As Object 'FileSystemObject 
    Dim fldStart As Object 'Folder 
    Dim fld As Object 'Folder 
    Dim fl As Object 'File 
    Dim Mask As String 

    Set fso = CreateObject("scripting.FileSystemObject") ' late binding 
    'Set fso = New FileSystemObject 'or use early binding (also replace Object types) 

    Set fldStart = fso.GetFolder("C:\Your\Start\Folder") ' <-- use your FileDialog code here 

    Mask = "*.xls" 
    Debug.Print fldStart.Path & "\" 
    ListFiles fldStart, Mask 
    For Each fld In fldStart.SubFolders 
     ListFiles fld, Mask 
     ListFolders fld, Mask 
    Next 
End Sub 


Sub ListFolders(fldStart As Object, Mask As String) 
    Dim fld As Object 'Folder 
    For Each fld In fldStart.SubFolders 
     Debug.Print fld.Path & "\" 
     ListFiles fld, Mask 
     ListFolders fld, Mask 
    Next 

End Sub 

Sub ListFiles(fld As Object, Mask As String) 
    Dim fl As Object 'File 
    For Each fl In fld.Files 
     If fl.Name Like Mask Then 
      Debug.Print fld.Path & "\" & fl.Name 
     End If 
    Next 
End Sub 

Answer 2

Sub MoFileTrongCacFolder() 

    Dim FSO As Object, fld As Object, Fil As Object 
    Dim fsoFile As Object 
    Dim fsoFol As Object 
    Dim fileName As String 
    Dim folderPath As String 
    Dim wbkCS As Object 

    MsgBox "Please choose the folder." 
    Application.DisplayAlerts = False 
    With Application.FileDialog(msoFileDialogFolderPicker) 
     .InitialFileName = "\\blah\test\" 
     .AllowMultiSelect = False 
     If .Show <> -1 Then MsgBox "No folder selected! Exiting script.": Exit Sub 
     folderPath = .SelectedItems(1) 
    End With 

    If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\" 
    Set FSO = CreateObject("Scripting.FileSystemObject") 
    Set fld = FSO.getfolder(folderPath) 
    If FSO.folderExists(fld) Then 
     For Each fsoFol In FSO.getfolder(folderPath).subfolders 
      For Each fsoFile In fsoFol.Files 
       If Mid(fsoFile.Name, InStrRev(fsoFile.Name, ".") + 1) = "xls" Then 
        fileName = fsoFile.Name 
        Application.ScreenUpdating = False 
        Set wbkCS = Workbooks.Open(fsoFile.Path) 

        'My file handling code 


       End If 
      Next 
     Next 
    End If 
End Sub 

Answer 3

這裏是一個VBA解決方案，而不使用外部對象。

由於Dir()函數的限制，您需要一次獲取每個文件夾的全部內容，而不是使用遞歸算法進行爬網。

Function GetFilesIn(Folder As String) As Collection 
    Dim F As String 
    Set GetFilesIn = New Collection 
    F = Dir(Folder & "\*") 
    Do While F <> "" 
    GetFilesIn.Add F 
    F = Dir 
    Loop 
End Function 

Function GetFoldersIn(Folder As String) As Collection 
    Dim F As String 
    Set GetFoldersIn = New Collection 
    F = Dir(Folder & "\*", vbDirectory) 
    Do While F <> "" 
    If GetAttr(Folder & "\" & F) And vbDirectory Then GetFoldersIn.Add F 
    F = Dir 
    Loop 
End Function 

Sub Test() 
    Dim C As Collection, F 

    Debug.Print 
    Debug.Print "Files in C:\" 
    Set C = GetFilesIn("C:\") 
    For Each F In C 
    Debug.Print F 
    Next F 

    Debug.Print 
    Debug.Print "Folders in C:\" 
    Set C = GetFoldersIn("C:\") 
    For Each F In C 
    Debug.Print F 
    Next F 
End Sub