VBA代码优化：保留最新重复项及删除Tabelle14匹配行

先回顾下你当前在用的代码：

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim lr As Long, lrT3 As Long, inAV As Boolean
 lr = Me.Rows.Count
 lrT3 = Me.Range("A" & lr).End(xlUp).Offset(8).Row
 inAV = Not Intersect(Target, Me.Range("AV9:AV" & lrT3)) Is Nothing
 With Target
 'Exit Sub if pasting multiples values, Target is not in col AV, or is empty
 If .Cells.CountLarge > 1 Or Not inAV Then Exit Sub
 Application.EnableEvents = False
 If .Value = "Relevant" Or .Value = "For Discussion" Then
 Me.Cells(.Row, "A").Resize(, 57).Copy
 With Tabelle14.Range("A" & lr).End(xlUp).Offset(1)
 .PasteSpecial xlPasteValues
 .PasteSpecial xlPasteFormats
 .PasteSpecial xlPasteColumnWidths
 End With
 Me.Cells(.Row, "A").Resize(, 2).Copy
 With Tabelle10
 .Range("A" & lr).End(xlUp).Offset(1).PasteSpecial xlPasteValues
 End With
 ElseIf .Value = "Not Relevant" Then
 Me.Cells(.Row, "A").Resize(, 2).Copy
 With Tabelle10
 .Range("A" & lr).End(xlUp).Offset(1).PasteSpecial xlPasteValues
 End With
 End If
 Application.CutCopyMode = False
 Application.EnableEvents = True
 End With
 '//Delete all duplicate rows
 Tabelle10.UsedRange.Offset(3).RemoveDuplicates Columns:=Array(1, 2)
 Tabelle14.UsedRange.Offset(3).RemoveDuplicates Columns:=Array(1, 2)
End Sub

问题1：保留Tabelle14最新状态条目，避免去重删除新内容 #

问题根源 #

当前代码是先复制新条目，再执行RemoveDuplicates，而Excel默认会保留第一行重复项、删除后续行，导致刚复制的最新状态条目被删掉。

解决思路 #

在复制新条目到Tabelle14之前，先主动删除表中已存在的同识别码（A列）旧条目，这样新复制的内容就是唯一的，不需要依赖后续批量去重。

问题2：状态设为"Not Relevant"时，用FIND删除Tabelle14匹配行 #

解决思路 #

用Range.Find精准定位Tabelle14中A列与当前行A列识别码匹配的单元格，找到后删除对应整行；同时处理“找不到匹配”的情况，循环遍历确保所有匹配行都被删除（即使识别码唯一，也能覆盖特殊场景）。

修改后的完整代码 #

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim lr As Long, lrT3 As Long, inAV As Boolean
    Dim currentID As String
    Dim foundCell As Range
    Dim firstFoundAddress As String
    
    lr = Me.Rows.Count
    lrT3 = Me.Range("A" & lr).End(xlUp).Offset(8).Row
    inAV = Not Intersect(Target, Me.Range("AV9:AV" & lrT3)) Is Nothing
    
    With Target
        '排除批量粘贴、非AV列、空值的情况
        If .Cells.CountLarge > 1 Or Not inAV Or .Value = "" Then Exit Sub
        
        Application.EnableEvents = False
        currentID = Me.Cells(.Row, "A").Value '获取当前行的识别码
        
        If .Value = "Relevant" Or .Value = "For Discussion" Then
            '--- 先删除Tabelle14中已存在的同识别码条目 ---
            With Tabelle14.UsedRange.Offset(3) '跳过前3行表头
                Set foundCell = .Columns(1).Find(What:=currentID, LookAt:=xlWhole, MatchCase:=False)
                If Not foundCell Is Nothing Then
                    firstFoundAddress = foundCell.Address
                    Do
                        Tabelle14.Rows(foundCell.Row).Delete
                        Set foundCell = .Columns(1).FindNext(foundCell)
                    Loop While Not foundCell Is Nothing And foundCell.Address <> firstFoundAddress
                End If
            End With
            
            '复制当前行到Tabelle14
            Me.Cells(.Row, "A").Resize(, 57).Copy
            With Tabelle14.Range("A" & lr).End(xlUp).Offset(1)
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                .PasteSpecial xlPasteColumnWidths
            End With
            
            'Tabelle10同样先删旧条目再新增，避免重复
            With Tabelle10.UsedRange.Offset(3)
                Set foundCell = .Columns(1).Find(What:=currentID, LookAt:=xlWhole, MatchCase:=False)
                If Not foundCell Is Nothing Then
                    firstFoundAddress = foundCell.Address
                    Do
                        Tabelle10.Rows(foundCell.Row).Delete
                        Set foundCell = .Columns(1).FindNext(foundCell)
                    Loop While Not foundCell Is Nothing And foundCell.Address <> firstFoundAddress
                End If
            End With
            Me.Cells(.Row, "A").Resize(, 2).Copy
            Tabelle10.Range("A" & lr).End(xlUp).Offset(1).PasteSpecial xlPasteValues
            
        ElseIf .Value = "Not Relevant" Then
            '--- 用FIND删除Tabelle14中匹配的行 ---
            With Tabelle14.UsedRange.Offset(3)
                Set foundCell = .Columns(1).Find(What:=currentID, LookAt:=xlWhole, MatchCase:=False)
                If Not foundCell Is Nothing Then
                    firstFoundAddress = foundCell.Address
                    Do
                        Tabelle14.Rows(foundCell.Row).Delete
                        Set foundCell = .Columns(1).FindNext(foundCell)
                    Loop While Not foundCell Is Nothing And foundCell.Address <> firstFoundAddress
                End If
            End With
            
            'Tabelle10先删旧条目再新增
            With Tabelle10.UsedRange.Offset(3)
                Set foundCell = .Columns(1).Find(What:=currentID, LookAt:=xlWhole, MatchCase:=False)
                If Not foundCell Is Nothing Then
                    firstFoundAddress = foundCell.Address
                    Do
                        Tabelle10.Rows(foundCell.Row).Delete
                        Set foundCell = .Columns(1).FindNext(foundCell)
                    Loop While Not foundCell Is Nothing And foundCell.Address <> firstFoundAddress
                End If
            End With
            Me.Cells(.Row, "A").Resize(, 2).Copy
            Tabelle10.Range("A" & lr).End(xlUp).Offset(1).PasteSpecial xlPasteValues
        End If
        
        Application.CutCopyMode = False
        Application.EnableEvents = True
    End With
    
    '移除原批量去重语句，因为已主动维护唯一性
    'Tabelle10.UsedRange.Offset(3).RemoveDuplicates Columns:=Array(1, 2)
    'Tabelle14.UsedRange.Offset(3).RemoveDuplicates Columns:=Array(1, 2)
End Sub

关键修改说明 #

1. 问题1解决：

   • 新增“先删旧条目、再复制新内容”的逻辑，从根源避免重复，不再依赖RemoveDuplicates的默认规则，确保最新状态被保留。
   • 移除了原批量去重语句，减少不必要的性能消耗。

2. 问题2解决：

   • 用Find+FindNext循环遍历Tabelle14，精准定位并删除所有匹配识别码的行；LookAt:=xlWhole确保是精确匹配，避免误删相似内容。
   • 记录第一个匹配地址，防止循环无限执行。

3. 其他优化：

   • 增加空值判断，避免空单元格触发无效操作；
   • 复用查找删除逻辑，让代码更简洁易维护；
   • 保持EnableEvents的开关，防止触发循环事件。

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