VBA代码修改：按Excel列表部分文件名匹配批量复制所有匹配文件

现有可正常运行的VBA代码，支持基于Excel列表存储的部分文件名规则，完成指定路径下文件的复制/移动操作。当前代码存在缺陷：当源文件夹内存在多个文件名前缀与给定关键词匹配的文件时，仅会复制/移动首个匹配到的文件，无法批量处理所有符合规则的文件。

VBA的Dir()函数首次调用传入匹配规则时，仅返回第一个符合条件的文件名；后续需要反复调用无参数的Dir()，才能依次获取剩余的匹配文件，直到函数返回空字符串代表遍历结束。原代码仅执行了一次Dir()调用，未做循环遍历，因此只能处理首个匹配文件。

• 为每个关键词的匹配结果增加遍历循环，拿到首个匹配文件后持续调用Dir()获取所有同规则匹配的文件
• 保留原有的路径合法性校验、空单元格跳过、目标路径重名文件跳过逻辑
• 调整计数规则，准确统计复制成功、目标已存在、未找到匹配文件、空单元格的数量

Sub CopyFilesFromListPartial()
    
    Const sPath As String = "E:\Asianet2"
    Const dpath As String = "E:\Asianet\EMIS"
    Const fRow As Long = 2
    Const Col As String = "A"
    
    ' 引用目标工作表
    Dim ws As Worksheet: Set ws = Sheet1
    
    ' 计算关键词列最后一行非空行号
    Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row
                 
    ' 早期绑定：需先在工具-引用中勾选Microsoft Scripting Runtime（支持代码智能提示）
    Dim fso As Scripting.FileSystemObject
    Set fso = New Scripting.FileSystemObject
    ' 后期绑定：无需添加引用，无智能提示
    'Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' 校验源文件夹路径
    Dim sFolderPath As String: sFolderPath = sPath
    If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"
    If Not fso.FolderExists(sFolderPath) Then
        MsgBox "源文件夹路径 '" & sFolderPath & "' 不存在，请检查配置。", vbCritical
        Exit Sub
    End If
    
    ' 校验目标文件夹路径
    Dim dFolderPath As String: dFolderPath = dpath
    If Right(dFolderPath, 1) <> "\" Then dFolderPath = dFolderPath & "\"
    If Not fso.FolderExists(dFolderPath) Then
        MsgBox "目标文件夹路径 '" & dFolderPath & "' 不存在，请检查配置。", vbCritical
        Exit Sub
    End If
    
    Dim r As Long ' 关键词列当前行号
    Dim sFilePath As String
    Dim sPartialFileName As String
    Dim sFileName As String
    Dim dFilePath As String
    Dim sYesCount As Long ' 成功复制的文件计数
    Dim sNoCount As Long ' 未找到匹配文件的关键词计数
    Dim dYesCount As Long ' 目标路径已存在同名文件的计数
    Dim BlanksCount As Long ' 空单元格计数
    
    For r = fRow To lRow
        sPartialFileName = CStr(ws.Cells(r, Col).Value)
        If Len(sPartialFileName) > 3 Then ' 单元格非空，执行匹配
            ' 前缀匹配规则：文件名以sPartialFileName开头
            sFileName = Dir(sFolderPath & sPartialFileName & "*")
            ' 若需要改为包含匹配（文件名中含关键词即可），替换为下一行代码
            'sFileName = Dir(sFolderPath & "*" & sPartialFileName & "*")
            
            If Len(sFileName) = 0 Then ' 无匹配文件
                sNoCount = sNoCount + 1
            Else
                ' 循环遍历所有匹配到的文件
                Do While Len(sFileName) > 0
                    sFilePath = sFolderPath & sFileName
                    dFilePath = dFolderPath & sFileName
                    If Not fso.FileExists(dFilePath) Then
                        ' 目标路径无同名文件，执行复制
                        fso.CopyFile sFilePath, dFilePath
                        ' 若需要改为移动文件，将上一行替换为 fso.MoveFile sFilePath, dFilePath
                        sYesCount = sYesCount + 1
                    Else
                        ' 目标路径已存在同名文件，跳过
                        dYesCount = dYesCount + 1
                    End If
                    ' 获取下一个匹配文件
                    sFileName = Dir
                Loop
            End If
        Else ' 单元格为空
            BlanksCount = BlanksCount + 1
        End If
    Next r

    ' 执行完成后弹出统计结果
    MsgBox "操作完成！" & vbCrLf & _
           "成功复制文件数：" & sYesCount & vbCrLf & _
           "目标路径已存在同名文件数：" & dYesCount & vbCrLf & _
           "未找到匹配文件的关键词数：" & sNoCount & vbCrLf & _
           "空单元格数：" & BlanksCount, vbInformation

End Sub

• 若需要将复制操作改为移动操作，仅需将代码中fso.CopyFile替换为fso.MoveFile即可
• 若需要将前缀匹配改为文件名包含关键词的模糊匹配，替换代码中对应Dir调用的匹配规则即可
• 代码执行完成后会弹出统计弹窗，直观展示各类操作的计数结果

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