Excel VBA文件复制代码异常：主文件夹外额外创建子文件夹问题

你的代码出现额外在主文件夹外创建子文件夹的问题，核心原因是删除逻辑错误地指向了目标根路径（而非主文件夹内的子文件夹），同时路径处理的可靠性不足。以下是具体修复方案：

修正后的完整代码 #

Sub Copyfiles()
    ' Updateby Extendoffice
    Dim xRg As Range, xCell As Range
    Dim xSFileDlg As FileDialog, xDFileDlg As FileDialog
    Dim xSPathStr As Variant, xDPathStr As Variant
    Dim xVal As String
    Dim FSO As Object, folder1 As Object

    Set xRg = Application.InputBox("请选择文件名所在单元格:", "KuTools For Excel", ActiveWindow.RangeSelection.Address, , , , , 8)
    If xRg Is Nothing Then Exit Sub

    Set xSFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    xSFileDlg.Title = "请选择源文件夹:"
    If xSFileDlg.Show <> -1 Then Exit Sub
    xSPathStr = xSFileDlg.SelectedItems.Item(1) & "\"

    Set xDFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    xDFileDlg.Title = "请选择目标文件夹:"
    If xDFileDlg.Show <> -1 Then Exit Sub
    xDPathStr = xDFileDlg.SelectedItems.Item(1) & "\"

    Call sCopyFiles(xRg, xSPathStr, xDPathStr)
End Sub

Sub sCopyFiles(xRg As Range, xSPathStr As Variant, xDPathStr As Variant)
    Dim xCell As Range
    Dim xVal As String
    Dim xMainFolderPath As String ' 重命名变量区分名称与完整路径
    Dim xSubFolderPath As String
    Dim FSO As Object
    Dim xI As Integer

    Set FSO = CreateObject("Scripting.FileSystemObject")
    ' 确保目标根文件夹存在
    If Not FSO.FolderExists(xDPathStr) Then
        FSO.CreateFolder xDPathStr
    End If

    For xI = 1 To xRg.Count
        Set xCell = xRg.Item(xI)
        xVal = xCell.Value
        Dim xMainFolderName As String: xMainFolderName = xCell.Offset(0, 1).Value ' B列：主文件夹名称
        Dim xSubFolderName As String: xSubFolderName = xCell.Offset(0, 2).Value ' C列：子文件夹名称

        If xMainFolderName <> "" Then
            ' 拼接主文件夹完整路径
            xMainFolderPath = FSO.BuildPath(xDPathStr, xMainFolderName)
            ' 确保主文件夹存在
            If Not FSO.FolderExists(xMainFolderPath) Then
                FSO.CreateFolder xMainFolderPath
            End If

            If xSubFolderName <> "" Then
                If TypeName(xVal) = "String" And xVal <> "" Then
                    On Error GoTo ErrorHandler
                    Dim sourceFilePath As String: sourceFilePath = FSO.BuildPath(xSPathStr, xVal)
                    ' 检查源文件是否存在
                    If FSO.FileExists(sourceFilePath) Then
                        ' 拼接子文件夹完整路径（主文件夹内）
                        xSubFolderPath = FSO.BuildPath(xMainFolderPath, xSubFolderName)
                        ' 删除主文件夹内同名子文件夹/文件（而非根路径下）
                        If FSO.FolderExists(xSubFolderPath) Then
                            FSO.DeleteFolder xSubFolderPath, True
                        ElseIf FSO.FileExists(FSO.BuildPath(xMainFolderPath, xVal)) Then
                            FSO.DeleteFile FSO.BuildPath(xMainFolderPath, xVal), True
                        End If
                        
                        ' 创建主文件夹内的子文件夹
                        If Not FSO.FolderExists(xSubFolderPath) Then
                            FSO.CreateFolder xSubFolderPath
                        End If
                        
                        ' 复制文件到子文件夹
                        FSO.CopyFile sourceFilePath, FSO.BuildPath(xSubFolderPath, xVal), True
                    End If
                End If
            Else
                If TypeName(xVal) = "String" And xVal <> "" Then
                    On Error GoTo ErrorHandler
                    Dim sourceFileMain As String: sourceFileMain = FSO.BuildPath(xSPathStr, xVal)
                    If FSO.FileExists(sourceFileMain) Then
                        ' 删除主文件夹内同名文件
                        Dim destFileMain As String: destFileMain = FSO.BuildPath(xMainFolderPath, xVal)
                        If FSO.FileExists(destFileMain) Then
                            FSO.DeleteFile destFileMain, True
                        End If
                        
                        ' 复制文件到主文件夹
                        FSO.CopyFile sourceFileMain, destFileMain, True
                    End If
                End If
            End If
        Else
            ' 无主文件夹时，直接复制到目标根路径
            If TypeName(xVal) = "String" And xVal <> "" Then
                On Error GoTo ErrorHandler
                Dim sourceFileRoot As String: sourceFileRoot = FSO.BuildPath(xSPathStr, xVal)
                If FSO.FileExists(sourceFileRoot) Then
                    Dim destFileRoot As String: destFileRoot = FSO.BuildPath(xDPathStr, xVal)
                    If FSO.FileExists(destFileRoot) Then
                        FSO.DeleteFile destFileRoot, True
                    End If
                    
                    FSO.CopyFile sourceFileRoot, destFileRoot, True
                End If
            End If
        End If
        ' 跳过错误处理，继续下一个文件
        GoTo NextFile
ErrorHandler:
        MsgBox "处理文件 " & xVal & " 时出错: " & Err.Description, vbExclamation
NextFile:
    Next xI
End Sub

关键修改说明 #

1. 修复删除逻辑：将原代码中检查/删除xDPathStr & xSubFolder（目标根路径下的子文件夹）的逻辑，改为操作xMainFolderPath & xSubFolderName（主文件夹内的子文件夹），彻底避免误操作根路径下的内容。
2. 使用FSO路径工具：用FSO.BuildPath替代手动拼接路径，自动处理反斜杠问题，避免路径格式错误。
3. 替换MkDir为FSO.CreateFolder：FSO的文件夹创建方法更稳定，支持自动处理路径中的特殊字符，且无需手动添加反斜杠。
4. 优化错误处理：添加错误提示弹窗，便于排查问题，同时确保错误后能继续处理下一个文件。
5. 变量重命名：将模糊的变量名（如xMainFolder）改为更清晰的xMainFolderName和xMainFolderPath，避免混淆名称和完整路径。

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