基于下拉列表选择复制行至对应工作表的VBA代码故障排查

原代码存在的问题 #

• 仅监听E2单元格的变化，未覆盖E列所有带下拉选项的单元格（如E3、E4等）
• 目标工作表名称匹配错误：代码中使用Sheet3/Sheet4/Sheet5，但需求是复制到名为Active/Pending/Renewed的工作表
• 未处理多单元格批量修改的场景，批量操作时会触发错误
• 未禁用事件触发，复制行的操作会循环触发Worksheet_Change事件，导致异常

修正后的代码 #

将以下代码替换原代码，确保代码保存在All工作表的代码模块中：

Private Sub Worksheet_Change(ByVal Target As Range)
    ' 仅监听E列（从E2开始）的单元格变化
    Dim MonitorRange As Range
    Set MonitorRange = Me.Range("E2:E" & Me.Cells(Me.Rows.Count, "E").End(xlUp).Row)
    
    ' 检查目标单元格是否在监听范围内，且是单个单元格修改
    If Not Application.Intersect(Target, MonitorRange) Is Nothing And Target.Cells.Count = 1 Then
        ' 禁用事件触发，避免循环调用
        Application.EnableEvents = False
        
        Select Case Target.Value
            Case "Active"
                CopyRow Target.Row, "Active"
            Case "Pending"
                CopyRow Target.Row, "Pending"
            Case "Renewed"
                CopyRow Target.Row, "Renewed"
        End Select
        
        ' 恢复事件触发
        Application.EnableEvents = True
    End If
End Sub

Sub CopyRow(rowNumber As Long, sheetName As String)
    Dim targetSheet As Worksheet
    Dim lastRow As Long
    
    ' 确认目标工作表存在
    On Error Resume Next
    Set targetSheet = ThisWorkbook.Sheets(sheetName)
    On Error GoTo 0
    
    If targetSheet Is Nothing Then
        MsgBox "目标工作表 '" & sheetName & "' 不存在，请检查名称。", vbExclamation
        Exit Sub
    End If
    
    ' 获取目标工作表最后一行
    lastRow = targetSheet.Cells(targetSheet.Rows.Count, 1).End(xlUp).Row + 1
    
    ' 复制整行到目标工作表
    Me.Rows(rowNumber).Copy Destination:=targetSheet.Rows(lastRow)
End Sub

关键修改说明 #

• 调整监听范围：改为监听E2到E列最后一个有数据的单元格，覆盖所有需要触发的行
• 修正目标工作表名称：直接使用需求中的Active/Pending/Renewed，确保匹配正确
• 添加事件禁用：避免复制操作触发Worksheet_Change事件，造成循环执行
• 增加工作表存在性检查：防止因工作表名称错误导致的运行时错误
• 优化行号数据类型：将Integer改为Long，避免处理超过32767行时的溢出问题

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