VBA代码修改需求：实现从主文件夹及子文件夹批量复制指定PDF证书文件

Hey there! Let's get that subfolder-searching VBA code working properly. Your original attempt had unclosed code blocks and was trying to use Dir in a way that doesn't handle nested folders well. Below is the fully corrected code, plus a breakdown of key fixes and improvements:

Corrected VBA Code #

Sub CopyCertsSubFolders()
    Application.ScreenUpdating = False
    Dim R As Range
    Dim destPath As String
    Dim fso As Object
    Dim foundFile As String
    
    ' Set destination folder (ensure it ends with a backslash)
    destPath = "C:\Users\GaryBaker\Desktop\Certs\"
    If Right(destPath, 1) <> "\" Then destPath = destPath & "\"
    
    ' Initialize FileSystemObject for reliable folder traversal
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' Loop through each certificate number in column E
    For Each R In Range("E5", Range("E" & Rows.Count).End(xlUp))
        ' Reset state and clear previous red formatting
        foundFile = ""
        R.Font.ColorIndex = xlAutomatic
        
        ' Get source root folder from column H (no need to activate cells!)
        Dim sourceRoot As String
        sourceRoot = R.Offset(0, 3).Value
        If sourceRoot = "" Then
            R.Font.Color = vbRed
            GoTo NextCert
        End If
        If Right(sourceRoot, 1) <> "\" Then sourceRoot = sourceRoot & "\"
        
        ' Search root folder and all subfolders recursively
        foundFile = FindFileInSubfolders(fso, sourceRoot, R.Value & ".pdf")
        
        ' Handle results: copy if found, mark red if missing
        If foundFile <> "" Then
            fso.CopyFile foundFile, destPath & fso.GetFileName(foundFile), OverWriteFiles:=True
        Else
            R.Font.Color = vbRed
        End If
        
NextCert:
    Next R
    
    MsgBox "File copy operation complete!", vbInformation
    Application.ScreenUpdating = True
End Sub

' Helper function to recursively search for a file in a folder and subfolders
Private Function FindFileInSubfolders(fso As Object, folderPath As String, fileName As String) As String
    Dim currentFolder As Object
    Dim subFolder As Object
    Dim file As Object
    
    Set currentFolder = fso.GetFolder(folderPath)
    
    ' Check files in current folder first
    For Each file In currentFolder.Files
        If LCase(file.Name) = LCase(fileName) Then
            FindFileInSubfolders = file.Path
            Exit Function
        End If
    Next file
    
    ' Recursively check all subfolders
    For Each subFolder In currentFolder.SubFolders
        FindFileInSubfolders = FindFileInSubfolders(fso, subFolder.Path, fileName)
        If FindFileInSubfolders <> "" Then Exit Function
    Next subFolder
    
    ' Return empty string if file not found anywhere
    FindFileInSubfolders = ""
End Function

Key Fixes & Improvements #

• Fixed Syntax Errors: Removed unclosed If/For blocks from your original code that caused "For without Next" and "Block If without End If" errors.
• Recursive Folder Search: Added a helper function FindFileInSubfolders that uses the FileSystemObject (FSO) to reliably scan every nested subfolder under the root path from column H—this is far more effective than trying to use Dir for deep folder searches.
• Removed Unnecessary Activate: VBA runs faster and more reliably when you directly reference cells instead of activating them. We now pull the source path straight from R.Offset(0,3) without cell activation.
• Robust Path Handling: Automatically adds a trailing backslash to paths to avoid file not found errors, and uses FSO's GetFileName method to safely extract filenames from full paths.
• Case-Insensitive Search: Compares filenames in lowercase to avoid missing files due to case differences (e.g., ABC123.pdf vs abc123.pdf).
• Cleaner Logic: Resets cell formatting before checking each file, and adds a check for empty source paths in column H (marks those entries red too).

内容的提问来源于stack exchange，提问作者Gary