修改VBA代码：多PDF归集到同一文件夹并以父文件夹命名

需求与问题说明 #

原代码存在两个核心问题：

1. 会为Excel A列中每一行匹配的PDF创建独立文件夹，无法将同文件名的PDF归集到同一目录
2. 目标文件夹以PDF文件名命名，不符合需求

需要实现的功能：

• 将所有匹配A列的PDF/CSV文件集中复制到同一个目标文件夹
• 目标文件夹名称使用当前Excel文件的父文件夹名称

修改后的完整VBA代码 #

Sub MatchFilesAndCopy()
    Dim srcPath As String
    Dim destBasePath As String
    Dim targetFolder As String
    Dim fso As Object
    Dim srcFolder As Object
    Dim srcFile As Object
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim cellValue As String
    Dim copiedFiles As Collection ' 记录已复制的文件，避免重复
    
    ' 初始化文件系统对象和已复制文件集合
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set copiedFiles = New Collection
    
    ' 源路径为当前Excel所在文件夹
    srcPath = ThisWorkbook.Path & "\"
    ' 基础目标路径
    destBasePath = "Z:\Team_WIP\Joe\VBATEST\RESULTS\"
    ' 目标文件夹名称为Excel所在的父文件夹名称
    targetFolder = destBasePath & fso.GetFolder(srcPath).Name
    
    ' 使用第一个工作表
    Set ws = ThisWorkbook.Sheets(1)
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' 打印调试信息
    Debug.Print "源路径: " & srcPath
    Debug.Print "目标文件夹: " & targetFolder
    
    ' 创建目标文件夹（如果不存在）
    If Not fso.FolderExists(targetFolder) Then
        fso.CreateFolder targetFolder
        Debug.Print "已创建目标文件夹: " & targetFolder
    End If
    
    ' 遍历源文件夹中的文件
    Set srcFolder = fso.GetFolder(srcPath)
    For Each srcFile In srcFolder.Files
        ' 只处理PDF和CSV文件
        If UCase(fso.GetExtensionName(srcFile.Name)) = "PDF" Or UCase(fso.GetExtensionName(srcFile.Name)) = "CSV" Then
            ' 遍历A列查找匹配项（跳过第一行表头）
            For i = 2 To lastRow
                cellValue = Trim(ws.Cells(i, 1).Value)
                ' 检查单元格值是否匹配文件名（过滤空单元格）
                If cellValue <> "" And InStr(1, srcFile.Name, cellValue, vbTextCompare) > 0 Then
                    On Error Resume Next
                    ' 检查文件是否已复制，避免重复操作
                    copiedFiles.Add srcFile.Path, Key:=srcFile.Path
                    If Err.Number = 0 Then
                        ' 复制文件到目标文件夹，支持覆盖已存在文件
                        fso.CopyFile srcFile.Path, targetFolder & "\" & srcFile.Name, OverWriteFiles:=True
                        Debug.Print "已复制文件: " & srcFile.Name & " 到 " & targetFolder
                    End If
                    On Error GoTo 0
                    Exit For ' 匹配到后退出内层循环，提升效率
                End If
            Next i
        End If
    Next srcFile
    
    ' 复制当前工作表到目标文件夹
    ThisWorkbook.Sheets(1).Copy
    With ActiveWorkbook
        .SaveAs targetFolder & "\" & ThisWorkbook.Name
        .Close SaveChanges:=False
    End With
    
    ' 释放对象
    Set fso = Nothing
    Set srcFolder = Nothing
    Set ws = Nothing
    Set copiedFiles = Nothing
    
    MsgBox "文件归集完成！目标文件夹：" & targetFolder, vbInformation
End Sub

关键修改点 #

• 统一目标文件夹：通过fso.GetFolder(srcPath).Name直接获取Excel所在父文件夹的名称作为目标文件夹名，且仅在启动时创建一次，避免重复创建报错
• 避免重复复制：使用Collection记录已复制的文件路径，防止同一文件因A列重复出现而被多次复制
• 优化匹配逻辑：跳过表头行，使用InStr进行不区分大小写的模糊匹配（如需精确匹配可改回原代码的cellValue = Left(srcFile.Name, Len(cellValue))判断），匹配到后立即退出内层循环提升运行效率
• 修复Excel副本保存：原代码中newFolder变量值不稳定，现在直接使用固定的targetFolder确保工作表副本保存到正确目录
• 稳定文件操作：使用FileSystemObject的原生方法替代MkDir和FileCopy，提供更可靠的文件操作支持，包含覆盖已存在文件的选项

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