如何修改VBA代码批量复制同前缀文件到多个目标文件夹

原代码仅调用了1次Dir()函数获取匹配结果，VBA中Dir(匹配规则)首次调用只会返回第一个符合规则的文件名，必须不带参数重复调用Dir()才能依次拿到剩余的同规则匹配文件，原逻辑缺少遍历所有匹配结果的循环，因此只能复制第一个命中前缀的文件。
另外原代码存在两处不合理判断：一是要求部分文件名长度大于3才处理，会漏过短文件名的合法条目；二是要求匹配到的文件名长度大于3才判定存在，会漏判短文件名的合法文件。

Sub CopyOrMoveFilesFromListPartial()
    
    ' -------------------------- 配置项 按需修改 --------------------------
    Const sPath As String = "E:\Testing\Source"       ' 源文件夹路径
    Const dpath As String = "E:\Testing\Destination"  ' 目标文件夹路径
    Const fRow As Long = 2                            ' 文件名列表起始行
    Const Col As String = "A"                         ' 文件名列表所在列
    Const OperationMode As String = "Copy"            ' 操作模式：填"Copy"为复制，填"Move"为移动
    Const MatchMode As String = "Prefix"              ' 匹配模式：填"Prefix"为前缀匹配，填"Contains"为包含匹配
    ' -------------------------------------------------------------------
    
    ' 引用工作表
    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  ' 列表中的空白单元格数
    Dim matchRule As String  ' 文件名匹配规则
    
    ' 遍历列表每一行
    For r = fRow To lRow
        sPartialFileName = CStr(Trim(ws.Cells(r, Col).Value))
        If Len(sPartialFileName) > 0 Then
            ' 生成匹配规则
            If MatchMode = "Contains" Then
                matchRule = sFolderPath & "*" & sPartialFileName & "*"
            Else
                matchRule = sFolderPath & sPartialFileName & "*"
            End If
            ' 获取第一个匹配文件
            sFileName = Dir(matchRule)
            
            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
                        ' 执行对应操作
                        Select Case OperationMode
                            Case "Move"
                                fso.MoveFile sFilePath, dFilePath
                            Case Else
                                fso.CopyFile sFilePath, dFilePath
                        End Select
                        sYesCount = sYesCount + 1
                    Else
                        ' 目标已存在同名文件，跳过
                        dYesCount = dYesCount + 1
                    End If
                    ' 获取下一个匹配文件
                    sFileName = Dir
                Loop
            End If
        Else
            ' 空白单元格计数
            BlanksCount = BlanksCount + 1
        End If
    Next r

    ' 操作完成弹窗提示
    MsgBox "文件操作执行完成！" & vbCrLf & vbCrLf & _
        "成功" & IIf(OperationMode = "Move", "移动", "复制") & "文件数：" & sYesCount & vbCrLf & _
        "目标路径已存在、跳过的文件数：" & dYesCount & vbCrLf & _
        "未找到匹配文件的条目数：" & sNoCount & vbCrLf & _
        "列表空白单元格数：" & BlanksCount, vbInformation

End Sub

• 新增内层Do While循环：首次调用Dir()拿到第一个匹配文件后，循环调用无参数Dir()获取剩余所有匹配文件，直到返回空字符串（无更多匹配项）为止，覆盖所有同前缀/包含关键词的文件
• 移除原代码不合理的长度判断：不再要求文件名、关键词长度大于3，只要关键词非空就执行匹配，避免漏过短文件名的合法文件
• 新增可配置项：无需修改核心逻辑，直接修改顶部常量即可切换复制/移动模式、前缀匹配/包含匹配模式
• 新增单元格内容自动去空格逻辑：避免单元格前后带不可见空格导致匹配失败
• 新增操作完成结果弹窗：执行结束后直接展示各状态的文件计数，不用手动核对结果
• 修正原计数逻辑bug：仅当某行关键词一个匹配文件都找不到时才计入「未找到」计数，避免同一行多个匹配文件时重复计数

注意：如果需要支持子文件夹内的文件匹配，需要额外加文件夹递归遍历逻辑，当前代码仅处理源文件夹根目录下的文件。

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