基于状态自动移动Excel表行至归档表的VBA代码修正需求

问题概述 #

• 需求：当「Current Projects」工作表第4列（Status）被选为「Completed」或「Cancelled」时，自动将该行前21列数据剪切至「Archive」工作表的现有表格下一行，避免覆盖已有数据且保留表格结构
• 原代码问题：
  • 首次尝试：报「subscript out of range（下标越界）」错误
  • 二次尝试：行被添加至Archive表格外部，破坏依赖表格格式的公式

原代码问题分析 #

1. 下标越界：大概率是工作表名称拼写错误，或On Error Resume Next掩盖了真实错误（如引用不存在的工作表/范围）
2. 表格结构破坏：直接写入Range("A" & B + 1)未利用Excel表格（ListObject）的扩展方法，导致行添加到表格外部
3. 冗余逻辑：两个模块分别处理两种状态，代码重复；工作表事件中Target(Z).Value > 0的判断错误（Status为文本值，不应做数值判断）
4. 遍历漏洞：正向遍历删除行时会跳过后续行；且Set rowx = Worksheets("Archive").AutoFilter.Range在无筛选状态下会报错

修正后的完整代码 #

1. 工作表事件代码（「Current Projects」工作表模块） #

打开「Current Projects」工作表，右键点击工作表标签→查看代码，粘贴以下代码：

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim targetCell As Range
    Dim statusCol As Range
    
    ' 仅监听第4列（Status列）的单元格变化
    Set statusCol = Me.Range("D:D")
    If Intersect(Target, statusCol) Is Nothing Then Exit Sub
    
    ' 禁用事件和屏幕刷新，避免循环触发及卡顿
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    ' 处理批量修改的场景（如粘贴多个状态值）
    For Each targetCell In Intersect(Target, statusCol)
        ' 统一转为大写判断，避免大小写输入差异
        Select Case UCase(CStr(targetCell.Value))
            Case "COMPLETED", "CANCELLED"
                ' 调用归档子过程，传递当前行对象
                ArchiveRow targetCell.EntireRow
        End Select
    Next targetCell
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

2. 标准模块代码 #

插入新模块（开发工具→插入→模块），粘贴以下代码：

Sub ArchiveRow(sourceRow As Range)
    Dim archiveSheet As Worksheet
    Dim archiveTable As ListObject
    Dim newTableRow As ListRow
    Dim sourceDataRange As Range
    
    ' 绑定Archive工作表和对应的表格（替换为你的实际表格名称）
    Set archiveSheet = ThisWorkbook.Worksheets("Archive")
    Set archiveTable = archiveSheet.ListObjects("Table_Archive") ' 修改为Archive工作表中表格的真实名称
    
    ' 仅取该行前21列数据（A到U列）
    Set sourceDataRange = sourceRow.Range("A1:U1")
    
    ' 在Archive表格末尾插入新行
    Set newTableRow = archiveTable.ListRows.Add(AlwaysInsert:=True)
    
    ' 复制数据并保留格式、数值
    sourceDataRange.Copy
    newTableRow.Range.PasteSpecial xlPasteValuesAndNumberFormats
    newTableRow.Range.PasteSpecial xlPasteFormats
    Application.CutCopyMode = False
    
    ' 删除原工作表中的目标行
    sourceRow.Delete
End Sub

关键注意事项 #

1. 表格名称修改：必须将archiveTable.ListObjects("Table_Archive")中的Table_Archive替换为你「Archive」工作表中实际的表格名称（可通过「表格设计」选项卡查看）
2. 事件触发限制：仅监听第4列的变化，避免无关操作触发代码
3. 表格结构保留：使用ListRows.Add方法直接在表格内添加行，自动扩展表格范围，确保依赖表格的公式正常工作
4. 鲁棒性优化：用UCase统一大小写判断，避免输入大小写差异导致失效；移除On Error Resume Next，便于排查潜在问题

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