如何修改VBA代码实现Excel部分文件名匹配并批量复制文件

下面是修改后的完整代码，已实现以Excel表格D列PO#为前缀匹配文件，并将所有匹配文件复制到「Found Files」子文件夹的功能：

Sub SearchFiles()
Dim ws                      As Worksheet
Dim tbl                     As ListObject
Dim cel                     As Range
Dim rootFolder              As String
Dim strNameNewSubFolder     As String
Dim fso                     As FileSystemObject
Dim sourceFolder            As Folder
Dim newFolder               As Folder
Dim fil                     As File
Dim hasMatch                As Boolean

Set fso = New FileSystemObject
Set ws = Worksheets("B")
Set tbl = ws.ListObjects(1)

' 源文件夹路径（请确认这里是你设置的正确路径）
rootFolder = "C:\Users\sktneer\Documents"

' 检查源文件夹是否存在
If Not fso.FolderExists(rootFolder) Then
    MsgBox rootFolder & " 不存在，请检查路径。", vbExclamation, "源文件夹未找到！"
    Exit Sub
End If

' 目标子文件夹名称
strNameNewSubFolder = "Found Files"

' 统一路径格式（确保末尾有Windows标准路径分隔符）
If Right(rootFolder, 1) <> "\" Then rootFolder = rootFolder & "\"

' 创建目标子文件夹（如果不存在）
If Not fso.FolderExists(rootFolder & strNameNewSubFolder) Then
    fso.CreateFolder rootFolder & strNameNewSubFolder
End If

Set sourceFolder = fso.GetFolder(rootFolder)
Set newFolder = fso.GetFolder(rootFolder & strNameNewSubFolder)

' 清除之前的单元格颜色标记
tbl.DataBodyRange.Columns(4).Interior.ColorIndex = xlNone

' 遍历D列的每个PO#
For Each cel In tbl.DataBodyRange.Columns(4).Cells
    hasMatch = False
    ' 遍历源文件夹中的所有文件
    For Each fil In sourceFolder.Files
        ' 判断文件名是否以当前PO#开头（不区分大小写）
        If LCase(Left(fil.Name, Len(cel.Value))) = LCase(cel.Value) Then
            ' 复制文件到目标文件夹，开启覆盖模式（如需保留同名文件可改OverWriteFiles为False）
            fil.Copy newFolder.Path & "\" & fil.Name, OverWriteFiles:=True
            hasMatch = True
        End If
    Next fil
    ' 如果有匹配文件，标记单元格为黄色
    If hasMatch Then
        cel.Interior.Color = vbYellow
    End If
Next cel

' 释放对象
Set fso = Nothing
MsgBox "文件匹配复制完成！", vbInformation, "操作完成"
End Sub

关键修改说明 #

• 前缀匹配逻辑：替换原代码的精确文件存在判断，改为遍历源文件夹所有文件，提取文件名前缀与PO#做不区分大小写的匹配，适配「PO#开头+后缀」的文件名格式
• 多文件处理：一个PO#对应多个文件时，所有匹配文件都会被复制，保留原文件的完整名称
• 路径兼容性：将原代码的/替换为Windows系统标准的\，避免路径识别错误
• 操作反馈：增加完成提示弹窗，便于确认操作结束
• 覆盖设置：复制时开启OverWriteFiles:=True，若目标文件夹已有同名文件会直接覆盖；如需保留原文件，可将该参数改为False，系统会自动给新文件加序号区分

内容的提问来源于stack exchange，提问作者Anthony Davis SF