Excel筛选宏失效：重复输出已存在条目问题求助

问题背景 #

一款使用数月的Excel宏突然失效，原本功能是检查索引是否存在于数据库表，筛选并列出「新条目」，现在却输出重复内容。已排查数据库索引列无异常，需从VBA代码找问题。涉及三个工作表：

• 输入数据：「1- colar nova base」
• 存储数据库：「sheet3」
• 输出表：「3- novos」

宏代码如下：

Sub NovosCasos()

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    
    Dim NIF As String
    Dim ActiveRow As Integer
    
    'Filter and copy the new data
    
    Sheets("1- Colar Base Nova").Select
    Range("A1").AutoFilter Field:=8, Criteria1:="DOC. EXPIRED"
    Rows("2:2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Delete Shift:=xlUp
    Range("A1").Select
    ActiveSheet.ShowAllData
    
    Rows("2:2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    
    Sheets("3 - Novos").Select
    Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    
    'Verifying new index value (NIF) and exclude existing ones
    
    ActiveRow = 2
    
    
    Limit = Range("c" & Rows.Count).End(xlUp).Row
    
    
    For i = 2 To Limit
        
        Do Until sheet2.Cells(ActiveRow, 3) = ""
        
            If sheet2.Cells(ActiveRow, 3) = Sheet3.Cells(i, 3) Then
                sheet2.Cells(ActiveRow, 3).EntireRow.Delete
            End If
        
            ActiveRow = ActiveRow + 1
        
        Loop
        
        ActiveRow = 2
        
    Next i
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.DisplayAlerts = True


End Sub

导致重复的核心原因 #

• 工作表引用错误：代码里用了sheet2，但实际输出表是「3- novos」，sheet2大概率指向了错误的工作表，导致根本没正确对比数据库里的条目，自然删不掉重复项。
• 删除行的循环逻辑漏洞：删除行后，下一行会自动上移，但代码里ActiveRow还在递增，会跳过新移上来的那一行，导致部分重复条目没被检查到。
• 循环范围错误：Limit = Range("c" & Rows.Count).End(xlUp).Row没指定工作表，默认取的是当前激活的「3- novos」的行数，而不是数据库表「sheet3」的行数，循环没遍历所有已存在的索引，漏删了重复项。
• 未清空旧数据：每次运行宏时，没先清空「3- novos」里A2以下的旧数据，新复制的数据和旧数据叠加，直接出现重复。

修正后的代码示例 #

Sub NovosCasos()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    
    Dim wsInput As Worksheet, wsDB As Worksheet, wsOutput As Worksheet
    Dim lastRowInput As Long, lastRowDB As Long, lastRowOutput As Long
    Dim i As Long, activeRow As Long
    
    '定义工作表对象，避免引用错误
    Set wsInput = Sheets("1- Colar Base Nova")
    Set wsDB = Sheets("sheet3")
    Set wsOutput = Sheets("3 - Novos")
    
    '第一步：过滤并删除输入表中过期的条目
    wsInput.Range("A1").AutoFilter Field:=8, Criteria1:="DOC. EXPIRED"
    With wsInput
        lastRowInput = .Range("A" & .Rows.Count).End(xlUp).Row
        If lastRowInput >= 2 Then
            .Range("2:" & lastRowInput).SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp
        End If
        .ShowAllData
    End With
    
    '第二步：清空输出表旧数据，复制新数据
    wsOutput.Range("A2:" & wsOutput.Cells(wsOutput.Rows.Count, "A").End(xlUp).EntireRow.Address).ClearContents
    lastRowInput = wsInput.Range("A" & wsInput.Rows.Count).End(xlUp).Row
    If lastRowInput >= 2 Then
        wsInput.Range("2:" & lastRowInput).Copy
        wsOutput.Range("A2").PasteSpecial Paste:=xlPasteValues
    End If
    
    '第三步：对比数据库，删除重复条目
    lastRowDB = wsDB.Range("C" & wsDB.Rows.Count).End(xlUp).Row
    lastRowOutput = wsOutput.Range("C" & wsOutput.Rows.Count).End(xlUp).Row
    
    '从下往上遍历，避免删除行导致的跳过问题
    For activeRow = lastRowOutput To 2 Step -1
        For i = 2 To lastRowDB
            If wsOutput.Cells(activeRow, 3).Value = wsDB.Cells(i, 3).Value Then
                wsOutput.Rows(activeRow).Delete
                Exit For '找到重复就跳出内层循环，检查下一行
            End If
        Next i
    Next activeRow
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.DisplayAlerts = True
End Sub

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