基于Excel列表移动文件夹：现有VBA代码仅能复制文件，求修改实现移动

你提供的代码使用FileCopy仅能处理单个文件，要实现整个文件夹的移动，需要改用VBA的Name语句（适合同盘符快速移动）或FileSystemObject（支持跨盘符移动）。以下是两种针对性修改的可行方案：

方案1：使用Name语句（同盘符场景） #

该方法适合源文件夹与目标文件夹在同一磁盘分区的情况，无需复制文件再删除原文件夹，移动速度更快：

Sub MoveFolders()
    Dim xRg As Range, xCell As Range
    Dim xSFileDlg As FileDialog, xDFileDlg As FileDialog
    Dim xSPathStr As String, xDPathStr As String
    Dim xFolderName As String
    Dim xSourcePath As String, xDestPath As String
    
    On Error Resume Next
    Set xRg = Application.InputBox("请选择要移动的文件夹名称列表:", "选择范围", 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) & "\"
    
    On Error GoTo ErrorHandler
    For Each xCell In xRg
        xFolderName = Trim(xCell.Value)
        If TypeName(xFolderName) = "String" And xFolderName <> "" Then
            xSourcePath = xSPathStr & xFolderName
            xDestPath = xDPathStr & xFolderName
            
            '检查源文件夹是否存在
            If Dir(xSourcePath, vbDirectory) <> "" Then
                '检查目标是否已有同名文件夹
                If Dir(xDestPath, vbDirectory) = "" Then
                    '执行文件夹移动（同盘符）
                    Name xSourcePath As xDestPath
                Else
                    MsgBox "目标目录已存在同名文件夹：" & xFolderName, vbExclamation
                End If
            Else
                MsgBox "源目录不存在：" & xFolderName, vbExclamation
            End If
        End If
    Next xCell
    MsgBox "文件夹移动完成！", vbInformation
    Exit Sub
    
ErrorHandler:
    MsgBox "移动文件夹时出错：" & Err.Description, vbCritical
End Sub

方案2：使用FileSystemObject（跨盘符场景） #

如果需要跨磁盘分区移动文件夹，推荐使用FileSystemObject，它会自动处理复制+删除的完整逻辑：

Sub MoveFoldersCrossDrive()
    Dim xRg As Range, xCell As Range
    Dim xSFileDlg As FileDialog, xDFileDlg As FileDialog
    Dim xSPathStr As String, xDPathStr As String
    Dim xFolderName As String
    Dim xSourcePath As String, xDestPath As String
    Dim fso As Object 'FileSystemObject实例
    
    '创建FileSystemObject对象
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    On Error Resume Next
    Set xRg = Application.InputBox("请选择要移动的文件夹名称列表:", "选择范围", 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) & "\"
    
    On Error GoTo ErrorHandler
    For Each xCell In xRg
        xFolderName = Trim(xCell.Value)
        If TypeName(xFolderName) = "String" And xFolderName <> "" Then
            xSourcePath = xSPathStr & xFolderName
            xDestPath = xDPathStr & xFolderName
            
            '检查源文件夹是否存在
            If fso.FolderExists(xSourcePath) Then
                '检查目标是否已有同名文件夹
                If Not fso.FolderExists(xDestPath) Then
                    '执行跨盘符文件夹移动
                    fso.MoveFolder Source:=xSourcePath, Destination:=xDestPath
                Else
                    MsgBox "目标目录已存在同名文件夹：" & xFolderName, vbExclamation
                End If
            Else
                MsgBox "源目录不存在：" & xFolderName, vbExclamation
            End If
        End If
    Next xCell
    MsgBox "文件夹移动完成！", vbInformation
    Exit Sub
    
ErrorHandler:
    MsgBox "移动文件夹时出错：" & Err.Description, vbCritical
    Set fso = Nothing
End Sub

核心修改说明 #

• 替换原代码的FileCopy语句：改用Name或FileSystemObject.MoveFolder专门处理文件夹移动
• 增加存在性校验：避免因源文件夹不存在、目标已有同名文件夹导致的运行错误
• 优化错误捕获：添加错误分支和提示，便于排查问题
• 适配中文操作提示：将原英文提示替换为中文，提升使用便捷性

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