VBA删除重复项首行异常求助：中间某重复值首行未被删除

问题根源 #

你遇到的部分重复值首行未被删除的问题，核心原因是从前往后循环+动态删除行导致的行号偏移：

• 当删除字典中记录的首行后，后续所有行的实际行号会自动减1，但字典里存储的旧行号和循环变量i并未同步更新
• 比如某重复值首行是行5，删除后原行6变成行5，但循环到i=6时，实际处理的是原行7，直接跳过了新的行5，导致逻辑混乱，部分首行未被正确识别删除

修复后的代码 #

推荐采用先标记所有需删除的首行，再批量删除的方式，彻底避免行号偏移问题，同时提升执行效率：

Sub ProcessDataAndRemoveDuplicates()
    Dim targetSheet As Worksheet
    Dim dataSheet As Worksheet
    Dim masterList As Range
    Dim lastRow As Long
    Dim i As Long
    Dim currentVal As Variant
    Dim dictDuplicates As Object
    Dim rowsToDelete As Range ' 存储待删除的行范围
    
    Set dictDuplicates = CreateObject("Scripting.Dictionary")
    Set rowsToDelete = Nothing ' 初始化空范围
    
    ' 设置工作表引用
    Set targetSheet = ThisWorkbook.Sheets("Total Renom")
    Set dataSheet = ThisWorkbook.Sheets("Active Sheet")
    Set masterList = ThisWorkbook.Sheets("Free Renom").Range("C:C")
    
    Application.ScreenUpdating = False
    Application.CutCopyMode = False
    
    ' 步骤1：复制数据到目标表
    targetSheet.UsedRange.Copy
    dataSheet.Range("A1").PasteSpecial Paste:=xlPasteValues
    
    ' 步骤2：删除参考列中存在值的行
    lastRow = dataSheet.Cells(dataSheet.Rows.Count, "P").End(xlUp).Row
    For i = lastRow To 2 Step -1
        currentVal = dataSheet.Cells(i, "P").Value
        If currentVal <> "" And Application.WorksheetFunction.CountIf(masterList, currentVal) > 0 Then
            dataSheet.Rows(i).Delete
        End If
    Next i
    
    ' 步骤3：按指定列排序
    lastRow = dataSheet.Cells(dataSheet.Rows.Count, "P").End(xlUp).Row
    With dataSheet.Sort
        .SortFields.Clear
        .SortFields.Add Key:=dataSheet.Range("P:P"), Order:=xlAscending ' 明确指定工作表，避免激活依赖
        .SortFields.Add Key:=dataSheet.Range("N:N"), Order:=xlAscending
        .SetRange dataSheet.Range("A1:R" & lastRow) ' 缩小排序范围，排除空行
        .Header = xlYes
        .Apply
    End With
    
    ' 步骤4：标记重复项的首行
    lastRow = dataSheet.Cells(dataSheet.Rows.Count, "P").End(xlUp).Row
    For i = 2 To lastRow
        currentVal = dataSheet.Cells(i, "P").Value
        If currentVal <> "" Then
            If Not dictDuplicates.Exists(currentVal) Then
                dictDuplicates.Add currentVal, i ' 记录首次出现的行号
            Else
                ' 首次发现重复时，将首行加入删除列表
                If rowsToDelete Is Nothing Then
                    Set rowsToDelete = dataSheet.Rows(dictDuplicates(currentVal))
                Else
                    Set rowsToDelete = Union(rowsToDelete, dataSheet.Rows(dictDuplicates(currentVal)))
                End If
                ' 更新字典为当前行号，确保后续重复项只保留最后一行
                dictDuplicates(currentVal) = i
            End If
        End If
    Next i
    
    ' 批量删除所有标记的行
    If Not rowsToDelete Is Nothing Then
        rowsToDelete.Delete
    End If
    
    Application.ScreenUpdating = True
    
    ' 返回工作表顶部
    dataSheet.Activate
    dataSheet.Cells(1, 1).Select
    
    MsgBox "Done! Data processed, duplicates removed, and returned to the top.", vbInformation
End Sub

关键优化点 #

1. 批量删除逻辑：用rowsToDelete范围统一记录待删除行，避免循环中动态删行导致的行号混乱
2. 明确工作表范围：排序时所有Range对象都指定dataSheet前缀，避免依赖当前激活工作表引发的错误
3. 缩小排序范围：用A1:R" & lastRow代替整列排序，排除空行提升效率
4. 修正重复项处理逻辑：仅在首次发现重复时标记首行，后续重复项更新字典记录，确保每个重复值只删除首行

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