修改VBA宏：将未匹配Excel列表的文件移至错误文件夹

需求说明 #

现有moveFilesFromListPartial宏可根据Excel工作表中的源文件名成功复制文件，运行状态正常。现需修改代码：当源文件夹中出现与Excel表内准确名称（如“Robert Anderson”）存在拼写错误的文件（如“Robert Andersonn”“Robertt Anderson”）时，需将这类未匹配Excel列表的文件复制到错误文件夹，而非留在源文件夹被后续moveAllFilesInDateFolderIfNotExist宏移至归档文件夹，以便每日快速识别并修正拼写错误。

修改后的moveFilesFromListPartial宏代码 #

Sub moveFilesFromListPartial()
    Const sPath As String = "E:\Uploading\Source"
    Const dPath As String = "E:\Uploading\Destination"
    Const ePath As String = "E:\Uploading\ErrorFiles" ' 新增错误文件夹路径
    Const fRow As Long = 2
    Const Col As String = "B", colExt As String = "C"

    ' 引用工作表
    Dim ws As Worksheet: Set ws = Sheet2

    ' 计算数据最后一行
    Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row
    ' 验证最后一行
    If lRow < fRow Then
        MsgBox "指定列无数据。", vbCritical
        Exit Sub
    End If

    ' 启用FileSystemObject（提前绑定，需引用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 eFolderPath As String: eFolderPath = ePath
    If Right(eFolderPath, 1) <> "\" Then eFolderPath = eFolderPath & "\"
    If Not fso.FolderExists(eFolderPath) Then
        fso.CreateFolder eFolderPath
        MsgBox "错误文件夹已创建：" & eFolderPath, vbInformation
    End If

    Dim matchedFiles As Collection ' 存储所有匹配成功的文件名
    Set matchedFiles = New Collection

    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 dYesCount As Long ' 目标已存在的文件数
    Dim BlanksCount As Long ' 空单元格数量
    Dim sExt As String ' 文件扩展名（含点）
    Dim errorCount As Long ' 移到错误文件夹的文件数

    ' 第一步：遍历Excel列表，收集所有匹配到的源文件名
    For r = fRow To lRow
        sPartialFileName = CStr(ws.Cells(r, Col).Value)
        sExt = CStr(ws.Cells(r, colExt).Value)

        If Len(sPartialFileName) > 3 Then ' 单元格非空
            ' 查找以指定名称开头、对应扩展名的文件
            sFileName = Dir(sFolderPath & sPartialFileName & "*" & sExt)
            Do While sFileName <> ""
                If Len(sFileName) > 3 Then ' 找到文件
                    sFilePath = sFolderPath & sFileName
                    dFilePath = dFolderPath & sFileName
                    ' 添加到匹配集合（避免重复）
                    On Error Resume Next
                    matchedFiles.Add sFileName, Key:=UCase(sFileName)
                    On Error GoTo 0

                    If Not fso.FileExists(dFilePath) Then
                        fso.CopyFile sFilePath, dFilePath
                        sYesCount = sYesCount + 1
                    Else
                        dYesCount = dYesCount + 1
                    End If
                End If
                sFileName = Dir
            Loop
        Else ' 单元格为空
            BlanksCount = BlanksCount + 1
        End If
    Next r

    ' 第二步：遍历源文件夹所有文件，将未匹配的移到错误文件夹
    sFileName = Dir(sFolderPath & "*.*")
    Do While sFileName <> ""
        ' 检查当前文件名是否在匹配集合中（不区分大小写）
        Dim isMatched As Boolean: isMatched = False
        On Error Resume Next
        isMatched = Not IsEmpty(matchedFiles(UCase(sFileName)))
        On Error GoTo 0

        If Not isMatched Then
            sFilePath = sFolderPath & sFileName
            Dim eFilePath As String: eFilePath = eFolderPath & sFileName
            ' 若错误文件夹已存在同名文件，覆盖或跳过（这里选择覆盖）
            If fso.FileExists(eFilePath) Then fso.DeleteFile eFilePath, True
            fso.CopyFile sFilePath, eFilePath
            errorCount = errorCount + 1
            ' 可选择删除源文件，若不需要保留则启用下面一行
            'fso.DeleteFile sFilePath, True
        End If
        sFileName = Dir
    Loop

    ' 显示统计结果
    MsgBox "操作完成：" & vbCrLf _
        & "成功移动到目标文件夹：" & sYesCount & " 个" & vbCrLf _
        & "目标文件夹已存在：" & dYesCount & " 个" & vbCrLf _
        & "移到错误文件夹：" & errorCount & " 个" & vbCrLf _
        & "空单元格数量：" & BlanksCount & " 个", vbInformation
End Sub

修改说明 #

1. 新增错误文件夹处理：添加ePath常量定义错误文件夹路径，若文件夹不存在则自动创建。
2. 匹配文件集合：新增matchedFiles集合存储所有从Excel列表匹配到的文件名，避免重复统计。
3. 遍历未匹配文件：在处理完Excel列表后，遍历源文件夹所有文件，检查是否在匹配集合中，未匹配的文件复制到错误文件夹。
4. 统计优化：新增errorCount变量统计错误文件数量，并在最后弹窗显示完整统计信息。
5. 大小写兼容：使用UCase()统一文件名大小写，避免因大小写差异导致的误判。

原归档宏代码（无需修改） #

Sub moveAllFilesInDateFolderIfNotExist()
    Dim DateFold As String, fileName As String, objFSO As Object
    Const sFolderPath As String = "E:\Uploading\Source"
    Const dFolderPath As String = "E:\Uploading\Archive"

    DateFold = dFolderPath & "\" & Format(Date, "ddmmyyyy") ' 创建当日归档文件夹
    If Dir(DateFold, vbDirectory) = "" Then MkDir DateFold

    fileName = Dir(sFolderPath & "\*.*")
    Set objFSO = CreateObject("Scripting.FileSystemObject")

    Do While fileName <> ""
        If Not objFSO.FileExists(DateFold & "\" & fileName) Then
            Name sFolderPath & "\" & fileName As DateFold & "\" & fileName
        Else
            Kill DateFold & "\" & fileName
            Name sFolderPath & "\" & fileName As DateFold & "\" & fileName
        End If
        fileName = Dir
    Loop
End Sub

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