VBA Worksheet_Change事件优化请求：重复复制与扫描范围问题

原代码功能：在Sheet1的E列查找值为“Match”的单元格，将对应行复制到Sheet2，但存在两个问题：

• 新增匹配项时会重复复制已复制过的旧行
• Worksheet_Change事件会扫描整个Sheet1的变更，而非仅响应E列变为“Match”的操作

优化思路 #

1. 避免重复复制：通过检查目标行的唯一标识（如A列内容）是否已存在于Sheet2，判断是否需要复制（无需新增辅助列）
2. 精准触发事件：仅当变更的单元格属于E列，且单元格新值为“Match”时，才执行复制逻辑，同时兼容批量修改场景

优化后的代码 #

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim targetCell As Range
    Dim lastRowWs2 As Long
    Dim isDuplicate As Boolean
    Dim i As Long
    
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Set ws2 = ThisWorkbook.Worksheets("Sheet2")
    
    ' 仅当ToggleButton1开启时执行
    If Not ws2.ToggleButton1.Value Then Exit Sub
    
    Application.EnableEvents = False
    On Error GoTo ResetEvents ' 确保出错时也能恢复事件
    
    ' 仅处理E列的变更
    Set targetCell = Intersect(Target, ws1.Range("E:E"))
    If targetCell Is Nothing Then GoTo ResetEvents
    
    ' 遍历所有变更的E列单元格（处理批量修改）
    For Each cell In targetCell
        ' 仅当单元格值变为"Match"时执行
        If cell.Value = "Match" Then
            ' 检查该行是否已复制到Sheet2（以A列为唯一标识）
            isDuplicate = False
            lastRowWs2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
            For i = 2 To lastRowWs2
                If ws2.Cells(i, 1).Value = ws1.Cells(cell.Row, 1).Value Then
                    isDuplicate = True
                    Exit For
                End If
            Next i
            
            ' 未复制过则执行复制
            If Not isDuplicate Then
                ' 直接复制行到Sheet2末尾，避免Activate/Select
                ws1.Rows(cell.Row).Copy Destination:=ws2.Cells(lastRowWs2 + 1, 1)
            End If
        End If
    Next cell

ResetEvents:
    Application.CutCopyMode = False
    Application.EnableEvents = True
End Sub

关键改动说明 #

• 精准触发：通过Intersect(Target, ws1.Range("E:E"))锁定仅处理E列变更，遍历每个变更单元格判断值是否为“Match”
• 去重逻辑：对比Sheet2的A列与当前行A列内容，避免重复复制
• 高效操作：移除Activate和Select，直接用Copy Destination完成复制，提升代码稳定性与速度
• 错误处理：添加On Error GoTo确保异常情况下事件能恢复启用

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