请求修改VBA文件整理代码：实现重复文件覆盖替换

要解决同名文件移动时报错的问题，核心是处理目标文件已存在的情况。FileSystemObject的MoveFile方法默认不支持覆盖，我们可以通过「先删除目标文件（如果存在）再移动」的方式实现需求。

修改后的完整代码 #

仅需替换MoveFilesToTypeFolders子过程中的文件移动逻辑，其余代码保持不变：

Sub MoveFilesToTypeFolders( _
        ByVal FolderPaths As Collection, _
        Optional ByVal ShowMessage As Boolean = True)
    Const PROC_TITLE As String = "Move Files To Type Folders"
    
    Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
    
    ' Keys: Type Folder Paths (New), Items: True or False i.e. exists or not
    Dim foDict As Object: Set foDict = CreateObject("Scripting.Dictionary")
    foDict.CompareMode = vbTextCompare
    
    ' Keys: File Paths (Old), Items: Type File Paths (New)
    Dim fiDict As Object: Set fiDict = CreateObject("Scripting.Dictionary")
    fiDict.CompareMode = vbTextCompare
    
    Dim Item, fsoFolder As Object, fsoFile As Object
    Dim FolderName As String, FileType As String, TypePath As String
    
    For Each Item In FolderPaths
        Set fsoFolder = FSO.GetFolder(Item)
        FolderName = fsoFolder.Name
        For Each fsoFile In fsoFolder.Files
            FileType = fsoFile.Type
            If StrComp(FolderName, FileType, vbTextCompare) <> 0 Then
                TypePath = FSO.BuildPath(Item, FileType)
                If Not foDict.Exists(TypePath) Then
                    foDict(TypePath) = FSO.FolderExists(TypePath)
                End If
                fiDict(fsoFile.Path) = FSO.BuildPath(TypePath, fsoFile.Name)
            'Else ' the file is already in its type folder; do nothing
            End If
        Next fsoFile
    Next Item
    
    ' Create the folders.
    For Each Item In foDict.Keys
        If Not foDict(Item) Then FSO.CreateFolder Item
    Next Item

    ' 移动文件（新增覆盖逻辑）
    Dim sourcePath As String, targetPath As String
    For Each Item In fiDict.Keys
        sourcePath = Item
        targetPath = fiDict(Item)
        Debug.Print sourcePath, targetPath
        
        ' 如果目标文件存在，先强制删除（支持删除只读文件）
        If FSO.FileExists(targetPath) Then
            FSO.DeleteFile targetPath, True
        End If
        ' 执行移动
        FSO.MoveFile sourcePath, targetPath
    Next Item

    If ShowMessage Then
        If fiDict.Count > 0 Then
            MsgBox "成功整理 " & fiDict.Count & " 个文件", vbInformation, PROC_TITLE
        Else
            MsgBox "没有需要整理的文件", vbInformation, PROC_TITLE
        End If
    End If

End Sub

关键修改说明 #

• 新增文件存在检查：移动前用FSO.FileExists(targetPath)判断目标文件是否存在
• 强制删除目标文件：调用FSO.DeleteFile targetPath, True，第二个参数True允许删除带只读属性的文件
• 完善操作提示：补充原代码缺失的弹窗提示，明确告知操作结果

可选方案：复制覆盖后删除原文件 #

若偏好复制方式，可将移动逻辑替换为：

' 移动文件（复制覆盖后删除原文件）
Dim sourcePath As String, targetPath As String
For Each Item In fiDict.Keys
    sourcePath = Item
    targetPath = fiDict(Item)
    Debug.Print sourcePath, targetPath
    
    ' 复制并覆盖目标文件（第三个参数True表示允许覆盖）
    FSO.CopyFile sourcePath, targetPath, True
    ' 删除原文件
    FSO.DeleteFile sourcePath, True
Next Item

两种方式均能实现覆盖效果，可按需选择。

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