单元格值变更时跨工作表移动行并简化VBA代码

解决空行问题 #

你碰到的空行问题，根源是用Cut + Insert仅剪切了行内容，原行本身仍留在原地变成空行。改用Range.Move方法可直接将整行移动到目标位置，原位置的行会自动被移除，无需额外调用Delete操作，彻底解决空行问题。

简化多条件判断 #

一堆独立的If语句不仅冗余，后期修改状态也容易遗漏。推荐两种简化方式：

方式1：Select Case分支（适合状态分组少的场景） #

结构清晰，状态对应关系一目了然：

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim KeyCells As Range
    Set KeyCells = Me.Range("A:A") ' 用Me指代当前工作表，避免跨表引用混乱
    
    ' 只处理单个单元格修改，批量修改直接跳过
    If Target.Cells.Count > 1 Then Exit Sub
    ' 检查修改的是否为"Project Status"列（假设为A列）
    If Application.Intersect(KeyCells, Target) Is Nothing Then Exit Sub
    
    On Error GoTo bm_Safe_Exit
    ' 禁用事件防止循环触发，关闭屏幕刷新提升效率
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    Select Case Target.Value
        Case 0, 1 ' 0和1对应同一目标位置
            Target.EntireRow.Move Before:=IdeasUpcoming.Range("4:4")
        Case 2
            Target.EntireRow.Move Before:=Current.Range("STATUSNewProjects").Offset(1, 0)
        Case 3
            Target.EntireRow.Move Before:=Current.Range("STATUSAdvancedProjects").Offset(1, 0)
        Case 4
            Target.EntireRow.Move Before:=Completed.Range("STATUSFinished").Offset(1, 0)
        Case 5
            Target.EntireRow.Move Before:=Completed.Range("STATUSOld").Offset(1, 0)
        ' 继续添加6-12的状态对应分支
        Case Else
            ' 状态不在0-12范围内时，可添加提示或直接跳过
    End Select

bm_Safe_Exit:
    ' 必须恢复事件和屏幕刷新，否则后续Change事件会失效
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

方式2：字典映射（更适合13个状态的场景） #

将状态与目标位置的对应关系集中存储在字典中，新增/修改状态只需调整映射条目，代码逻辑更简洁易维护：

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim KeyCells As Range
    Dim statusMap As Object
    Dim targetSheet As Worksheet
    Dim targetRange As Range
    
    Set KeyCells = Me.Range("A:A")
    Set statusMap = CreateObject("Scripting.Dictionary")
    
    ' 过滤批量修改和非目标列的情况
    If Target.Cells.Count > 1 Then Exit Sub
    If Application.Intersect(KeyCells, Target) Is Nothing Then Exit Sub
    
    ' 构建状态→目标工作表+位置的映射
    With statusMap
        .Add 0, Array(IdeasUpcoming, "4:4")
        .Add 1, Array(IdeasUpcoming, "4:4")
        .Add 2, Array(Current, Current.Range("STATUSNewProjects").Offset(1, 0))
        .Add 3, Array(Current, Current.Range("STATUSAdvancedProjects").Offset(1, 0))
        .Add 4, Array(Completed, Completed.Range("STATUSFinished").Offset(1, 0))
        .Add 5, Array(Completed, Completed.Range("STATUSOld").Offset(1, 0))
        ' 继续添加6-12的映射条目
    End With
    
    On Error GoTo bm_Safe_Exit
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    ' 若当前状态在映射表中，执行移动操作
    If statusMap.Exists(Target.Value) Then
        Set targetSheet = statusMap(Target.Value)(0)
        Set targetRange = statusMap(Target.Value)(1)
        Target.EntireRow.Move Before:=targetRange
    End If

bm_Safe_Exit:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    ' 释放对象避免内存占用
    Set statusMap = Nothing
    Set targetSheet = Nothing
    Set targetRange = Nothing
End Sub

额外注意事项 #

• 确保命名范围（如STATUSNewProjects）定义正确，否则会触发错误。
• 必须添加Application.EnableEvents = False，否则移动行时会触发目标工作表的Worksheet_Change事件，导致代码循环执行。
• 若需处理非数字输入，可在开头添加判断：If Not IsNumeric(Target.Value) Then Exit Sub。

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