遍历用户指定的根目录下的子文件夹和文件

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

- Mike

---

我会坚持使用 Dir 而不是 FSO，因为它可以使用通配符，这样就不需要进行冗长的文件类型检查来处理非 Excel 文件。请参见 https://dev59.com/HWkw5IYBdhLWcg3wirCs - brettdj

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

- chris neilsen

---

我会尝试使用这个并看看是否可以解决问题。谢谢Chris！ - Mike

能否将fso.GetFolder的路径分配给一个变量？我正在使用网络驱动器，因此CSRootDir是.SelectedItem的变量。等我回家后会进行更多研究，但我想知道你是否知道答案。谢谢。 - Mike

当然可以。只需使用您现有的代码获取根目录并将其传递给fso即可。 - chris neilsen

Chris，我最终修改了你的代码（我会发布），但你确实让我在使用FSO时找到了正确的方向。谢谢！ - Mike

我必须说，克里斯 - 这帮助我节省了大约十亿小时手动搜索电子表格。再次感谢！！ - Mike

有没有一种方法可以过滤您想要的文档类型，并阻止复制其他文件类型？ - user8285660

Answer 2

这里提供了一种不使用外部对象的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

- stenci

---

dir 的主要问题在于不支持网络路径（以 \ 开头）... - Gener4tor

Answer 3

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

- be09