vba 循环浏览用户指定根目录中的子文件夹和文件

Cycle through sub-folders and files in a user-specified root directory

提问by Mike

My cycling script through individual files works fine, but I now need it to also look through/for multiple directories. I am stuck....

我通过单个文件的循环脚本工作正常，但我现在还需要它来查看/查找多个目录。我卡住了....

The order things need to happen:

事情需要发生的顺序：

• User is prompted to choose root directory of what they need
• I need the script to look for any folders in that root directory
• If the script finds one, it opens the first one (all folders, so no specific search filter for the folders)
• Once open, my script will loop through all files in the folders and do what it needs to do
• after it's finished it closes the file, closes the directory and moves to the next one, etc..
• Loops until all folders have been opened/scanned

• 提示用户选择他们需要的根目录
• 我需要脚本来查找该根目录中的任何文件夹
• 如果脚本找到一个，它会打开第一个（所有文件夹，因此文件夹没有特定的搜索过滤器）
• 一旦打开，我的脚本将遍历文件夹中的所有文件并执行它需要执行的操作
• 完成后，它关闭文件，关闭目录并移动到下一个目录，依此类推。
• 循环直到所有文件夹都被打开/扫描

This is what I have, which doesn't work and I know is wrong:

这就是我所拥有的，它不起作用，我知道这是错误的：

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

Final Code. It cycles through all sub-directories and files in each sub-directory.

最终代码。它循环遍历所有子目录和每个子目录中的文件。

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

回答by chris neilsen

You might find it easier to use the FileSystemObject, somthing like this

您可能会发现使用FileSystemObject像这样的东西更容易

This dumps a folder/file list to the Immediate window

这会将文件夹/文件列表转储到 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

回答by stenci

Here is a VBA solution, without using external objects.

这是一个 VBA 解决方案，不使用外部对象。

Because of the limitations of the Dir()function you need to get the whole content of each folder at once, not while crawling with a recursive algorithm.

由于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

回答by be09

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