请求优化VBA代码：实现指定文件夹及子目录关键词文件批量复制

嗨Steven，我来帮你搞定这个文件复制的问题！你的需求是遍历源文件夹及其所有子目录，复制文件名包含指定关键词的文件，原代码的问题主要出在没处理子文件夹递归和通配符使用方式不对这两点上。下面是修改后的完整代码，以及关键改动的说明：

修改后的完整代码 #

Sub CopyFilesWithKeywords()
    Dim sourceFolder As String
    Dim destFolder As String
    Dim keywords As Variant
    
    ' 配置你的源文件夹、目标文件夹和需要匹配的关键词
    sourceFolder = "C:\Users\steven.byrne\Desktop\Test Folder 1\"
    destFolder = "C:\Users\steven.byrne\Desktop\Test Folder 2\"
    keywords = Array("As Sold", "Contract", "Class ID") ' 可按需添加/修改关键词
    
    ' 确保目标文件夹存在，不存在则自动创建
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(destFolder) Then
        fso.CreateFolder destFolder
    End If
    
    ' 启动递归遍历与文件复制
    Call CopyMatchingFiles(sourceFolder, destFolder, keywords, fso)
    
    MsgBox "文件复制任务完成！", vbInformation, "搞定啦"
End Sub

Private Sub CopyMatchingFiles(currentFolderPath As String, destFolder As String, keywords As Variant, fso As Object)
    Dim currentFolder As Object
    Dim subFolder As Object
    Dim file As Object
    Dim keyword As Variant
    Dim isMatch As Boolean
    
    Set currentFolder = fso.GetFolder(currentFolderPath)
    
    ' 遍历当前文件夹下的所有文件
    For Each file In currentFolder.Files
        isMatch = False
        ' 检查文件名是否包含任意一个目标关键词（不区分大小写）
        For Each keyword In keywords
            If InStr(1, LCase(file.Name), LCase(keyword), vbTextCompare) > 0 Then
                isMatch = True
                Exit For ' 找到匹配就跳出关键词循环
            End If
        Next keyword
        
        ' 如果匹配成功，执行复制操作
        If isMatch Then
            Dim destFilePath As String
            destFilePath = destFolder & file.Name
            
            ' 检查目标文件是否已存在，避免重复复制
            If Not fso.FileExists(destFilePath) Then
                fso.CopyFile file.Path, destFolder, True
                Debug.Print "已复制: " & file.Path & " → " & destFolder
            Else
                Debug.Print "文件已存在，跳过: " & destFilePath
                ' 若想直接覆盖无需提示，可删除上面的判断，直接保留fso.CopyFile这一行
            End If
        End If
    Next file
    
    ' 递归遍历所有子文件夹，实现深层目录搜索
    For Each subFolder In currentFolder.SubFolders
        Call CopyMatchingFiles(subFolder.Path, destFolder, keywords, fso)
    Next subFolder
End Sub

关键改动说明 #

1. 递归遍历子文件夹
   新增了CopyMatchingFiles私有子过程，它会先处理当前文件夹的文件，再自动递归处理每个子文件夹，彻底解决原代码只能搜索一级目录的问题。

2. 灵活的多关键词匹配
   用Array存储所有需要匹配的关键词，通过InStr函数结合LCase实现不区分大小写的关键词检查（如果需要严格区分大小写，可去掉LCase并将vbTextCompare改为vbBinaryCompare），比通配符更可靠灵活。

3. 通配符问题的替代方案
   原代码中*As*Sold*无法生效，是因为FileExists只支持简单通配符（比如*.xlsx），而我们通过遍历每个文件并判断关键词的方式，完美解决了复杂关键词匹配的需求。

4. 容错性优化
   新增了目标文件夹自动创建逻辑，避免因目标文件夹不存在导致复制失败；同时保留了文件重复检查，可选择提示跳过或直接覆盖。

使用方法 #

1. 修改sourceFolder和destFolder为你的实际路径；
2. 若要调整匹配关键词，直接修改keywords = Array(...)中的内容即可；
3. 在VBA编辑器中运行CopyFilesWithKeywords主过程，等待完成提示即可。

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