Excel VBA：如何更改代码以循环通过多个文件夹

Question

这篇文章是涉及到我刚才的问题这里 。

在工作簿“ CountResults.xlsm”中，我有一个代码遍历同一文件夹中的不同excel文件，并计算每个文件中特定列中“是”的数量。 然后将计数粘贴到“ CountResults.xlsm”中。

这是文件夹以前的样子：

现在我的问题是，我的测试文件将在另外两个文件夹中，因此我的代码无法接收它。 它从名为“ CodeResults”的文件夹开始，然后是文件夹“ Test0X” ，然后是“ S”和文件名。

例如 CodeResults-> Test01-> S-> Test01.xls

这是我的文件夹当前的样子：

这是我当前需要更改的代码 ，以便它可以读取每个文件夹中的excel文件：

Private Sub CommandButton1_Click()

    Dim r As Range
    With Worksheets("Sheet1")
        For Each r In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
            r.Offset(0, 1).Value = getYesCount(r.Value)
        Next
    End With
End Sub

Function getYesCount(WorkBookName As String) As Long
    Const FolderPath As String = "C:\Users\khanr1\Desktop\Excel_TEST\CodeUpdateTest"

    If Len(Dir(FolderPath & WorkBookName)) Then
        With Workbooks.Open(FolderPath & WorkBookName)
            With .Worksheets("Sheet2")
                 getYesCount = Application.CountIfs(.Range("D:D"), "YES", _
                                     .Range("B:B"), "*", _
                                     .Range("A:A"), "1")
            End With
            .Close False
        End With
    Else
        Debug.Print FolderPath & WorkBookName; ": Not Found"
    End If
End Function

供参考，这是我的Test01.xls的样子：

这是我的CountResults.xlsm的样子：

注意：我正在尝试找出解决方案。 我目前在CountResults.xlsm中使用名称“ A”列来查找文件。 因此，例如，我可以通过从此列中提取名称来打开文件夹Test01。

Answer 1

您需要使用递归循环。 我将给您两个做同样事情的样本。

Option Explicit

Sub ListAllFiles()
    'searchForFiles "c:\tushar\temp\", "processOneFile", "*.*", True, True
    searchForFiles "C:\Users\your_path_here\Desktop\Work Samples\", "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

也

Option Explicit

Sub TestListFolders()

    Application.ScreenUpdating = False

     'create a new workbook for the folder list

     'commented out by dr
     'Workbooks.Add

     'line added by dr to clear old data
    Cells.Delete

     ' add headers
    With Range("A1")
        .Formula = "Folder contents:"
        .Font.Bold = True
        .Font.Size = 12
    End With

    Range("A3").Formula = "Folder Path:"
    Range("B3").Formula = "Folder Name:"
    Range("C3").Formula = "Size:"
    Range("D3").Formula = "Subfolders:"
    Range("E3").Formula = "Files:"
    Range("F3").Formula = "Short Name:"
    Range("G3").Formula = "Short Path:"
    Range("A3:G3").Font.Bold = True

     'ENTER START FOLDER HERE
     ' and include subfolders (true/false)
    ListFolders "C:\Users\your_path_here\Desktop\Work Samples\", True

    Application.ScreenUpdating = True

End Sub

Sub ListFolders(SourceFolderName As String, IncludeSubfolders As Boolean)
     ' lists information about the folders in SourceFolder
     ' example: ListFolders "C:\", True
    Dim FSO As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
    Dim r As Long

    Set FSO = New Scripting.FileSystemObject
    Set SourceFolder = FSO.GetFolder(SourceFolderName)

     'line added by dr for repeated "Permission Denied" errors

    On Error Resume Next

     ' display folder properties
    r = Range("A65536").End(xlUp).Row + 1
    Cells(r, 1).Formula = SourceFolder.Path
    Cells(r, 2).Formula = SourceFolder.Name
    Cells(r, 3).Formula = SourceFolder.Size
    Cells(r, 4).Formula = SourceFolder.SubFolders.Count
    Cells(r, 5).Formula = SourceFolder.Files.Count
    Cells(r, 6).Formula = SourceFolder.ShortName
    Cells(r, 7).Formula = SourceFolder.ShortPath
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFolders SubFolder.Path, True
        Next SubFolder
        Set SubFolder = Nothing
    End If

    Columns("A:G").AutoFit

    Set SourceFolder = Nothing
    Set FSO = Nothing

     'commented out by dr
     'ActiveWorkbook.Saved = True

End Sub