基于下拉列表移动当前Excel工作簿的VBA实现问题

需求 #

• 将当前打开的带下拉列表的Excel工作簿移动（非复制）到其他文件夹
• 工作簿名称保持不变
• 通过下拉列表选择目标文件夹完成操作

示例：源文件夹为c:\test，目标文件夹为c:\dest\和c:\other\。选择下拉列表中的“Dest”，文件从c:\test\移至c:\dest\；选择“Other”则移至c:\other\（所有文件夹已预先创建）

我编写的代码无法正常运行 #

If Target.Column = 5 And Target.Row = 8 Then

    If Target.Value = "Dest" Then
        Dim sFileNameExt As String
        Dim sFilePath As String
        Dim sNewPath As String

        sNewPath = "c:\Dest\"
        sFilePath = ActiveWorkbook.Path
        sFileNameExt = ActiveWorkbook.Name
        ActiveWorkbook.SaveAs sNewPath & sFileNameExt
        Kill sFilePath & "\" & sFileNameExt
    ElseIf Target.Value = "Other" Then
        sNewPath = "c:\Other\"
        sFilePath = ActiveWorkbook.Path
        sFileNameExt = ActiveWorkbook.Name
        ActiveWorkbook.SaveAs sNewPath & sFileNameExt
        Kill sFilePath & "\" & sFileNameExt
    End If
End If

问题分析与修正代码 #

你的代码存在几个关键问题：

1. 变量声明位置不符合VBA规范，需在代码块开头统一声明
2. 使用SaveAs后原文件路径会丢失，导致Kill语句无法定位原文件
3. 缺少错误处理，操作失败时易造成文件丢失

修正后的代码（需放在对应工作表的Worksheet_Change事件中）：

Private Sub Worksheet_Change(ByVal Target As Range)
    ' 仅监听E8单元格（第5列第8行）的下拉选择变更
    If Not Intersect(Target, Me.Range("E8")) Is Nothing Then
        Dim sSourceFullPath As String
        Dim sFileName As String
        Dim sTargetFullPath As String
        
        ' 获取当前工作簿的完整路径和文件名
        sSourceFullPath = ActiveWorkbook.FullName
        sFileName = ActiveWorkbook.Name
        
        ' 根据下拉选项匹配目标路径
        Select Case Target.Value
            Case "Dest"
                sTargetFullPath = "C:\Dest\" & sFileName
            Case "Other"
                sTargetFullPath = "C:\Other\" & sFileName
            Case Else
                Exit Sub ' 选择非指定选项时终止操作
        End Select
        
        On Error GoTo ErrorHandler ' 启用错误捕获
        
        ' 先保存当前工作簿，避免未保存内容丢失
        ActiveWorkbook.Save
        
        ' 使用Name语句直接移动文件（比SaveAs+Kill更安全高效）
        Name sSourceFullPath As sTargetFullPath
        
        ' 关闭原工作簿并重新打开移动后的文件
        ActiveWorkbook.Close SaveChanges:=False
        Workbooks.Open sTargetFullPath
        
        Exit Sub
        
ErrorHandler:
        MsgBox "移动文件失败：" & Err.Description, vbExclamation
    End If
End Sub

使用步骤 #

1. 打开目标Excel工作簿，按Alt+F11打开VBA编辑器
2. 在左侧工程窗口中找到对应的工作表（如Sheet1），双击打开代码窗口
3. 将上述修正代码粘贴到窗口中
4. 返回Excel，确保E8单元格的下拉列表包含“Dest”和“Other”选项
5. 选择下拉选项后，工作簿会自动移动到目标文件夹并重新打开

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