VBA实现类Ctrl+F搜索：匹配文件名提取路径（宏运行无结果）

问题分析 #

你的宏运行无结果或不符合预期，核心问题有这几个：

• 复制对象错误：当前代码复制的是匹配到的文件名单元格（B列），但你需要的是左侧的文件路径（A列），应该取匹配单元格的左侧单元格。
• 目标单元格重复重置：Set destcell = Shtf.Cells(12, 4)放在循环内部，导致每次循环都把内容粘贴到D12，覆盖之前的结果，根本生成不了连续列表。
• 潜在工作表引用风险：直接用Sheet5/Sheet2依赖工作表的CodeName，要是工作表的CodeName和这个不匹配，就会找不到目标表。

修正后的代码 #

Sub TEST()
    Dim Shtf As Worksheet
    Dim ShtTDO As Worksheet
    Dim filematch As Range
    Dim destcell As Range
    Dim firstfilematch As String
    Dim filename As String

    ' 建议用工作表名称引用（比如Sheets("结果表")），比CodeName更直观不易错
    Set Shtf = Sheet5 ' 替换成 Sheets("你的结果工作表名称") 更稳妥
    filename = Shtf.Cells(6, 2).Value ' 从B6获取要搜索的文件名
    Set ShtTDO = Sheet2 ' 替换成 Sheets("数据工作表名称") 更稳妥

    ' 初始化目标单元格为D12，放在循环外避免重复重置
    Set destcell = Shtf.Cells(12, 4)

    ' 在数据工作表的B列搜索匹配文件名
    With ShtTDO.Range("B:B")
        Set filematch = .Find(filename, LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
        If Not filematch Is Nothing Then
            firstfilematch = filematch.Address
            Do
                ' 复制匹配单元格左侧的文件路径（A列）到目标单元格
                filematch.Offset(0, -1).Copy Destination:=destcell
                ' 目标单元格下移一行，准备存下一个结果
                Set destcell = destcell.Offset(1)
                ' 查找下一个匹配项
                Set filematch = .FindNext(filematch)
            Loop While Not filematch Is Nothing And filematch.Address <> firstfilematch
        End If
    End With
End Sub

调试小提示 #

• 确认Sheet5的B6单元格确实有要搜索的文件名，且和数据工作表B列的内容完全一致（LookAt:=xlWhole要求精确匹配，大小写敏感），要是需要模糊匹配，改成LookAt:=xlPart。
• 检查工作表CodeName：右键工作表标签→查看代码，在属性窗口的(Name)栏就是CodeName，确认和你代码里的Sheet5/Sheet2对应；嫌麻烦直接用Sheets("工作表显示名称")更不容易出错。

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