VBA实现Excel指定列去重 仅保留每组重复值首尾行

我手上有张20000行数据的Excel表，示例数据如下：

需要写VBA实现重复行删除，每组重复值仅保留第一行和最后一行，预期处理结果如下：

现有代码存在的问题 #

• 之前修改的一版代码可以实现需求，但每次运行必须手动选择header2列的重复值范围，操作繁琐，代码如下：

Sub Delete_Dups_Keep_Last_v2()
 Dim SelRng As Range
 Dim Cell_in_Rng As Range
 Dim RngToDelete As Range
 Dim SelLastRow As Long
 
    Application.DisplayAlerts = False
    Set SelRng = Application.InputBox("Select cells", Type:=8)
    On Error GoTo 0
    Application.DisplayAlerts = True
 
    SelLastRow = SelRng.Rows.Count + SelRng.Row - 1
    For Each Cell_in_Rng In SelRng
        
        If Cell_in_Rng.Row < SelLastRow Then
            If Cell_in_Rng.Row > SelRng.Row Then
                If Not Cell_in_Rng.Offset(1, 0).Resize(SelLastRow - Cell_in_Rng.Row).Find(What:=Cell_in_Rng.Value, Lookat:=xlWhole) Is Nothing Then
                    '判断该值后续是否还存在
                    If RngToDelete Is Nothing Then
                        Set RngToDelete = Cell_in_Rng
                    Else
                        Set RngToDelete = Application.Union(RngToDelete, Cell_in_Rng)
                    End If
                End If
            End If
        End If
        
    Next Cell_in_Rng
 
    If Not RngToDelete Is Nothing Then RngToDelete.EntireRow.Delete

End Sub

• 另一版基于Dictionary对象的代码可以自动识别数据范围，运行速度更快，但逻辑存在缺陷，无法正确保留每组重复值的首尾行，不符合预期，代码如下：

Sub keepFirstAndLast()
  Dim toDelete As Range: Set toDelete = Sheet1.Rows(999999) '初始化避免空范围报错
  Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")

  Dim a As Range
  For Each a In Sheet1.Range("B2", Sheet1.Range("B999999").End(xlUp))
    If Not dict.Exists(a.Value2) Then
      dict(a.Value2) = 0 '首次出现，不标记行
    Else
      ' 上一次出现的是重复值，加入待删除范围
      If dict(a.Value2) > 0 Then Set toDelete = Union(toDelete, Sheet1.Rows(dict(a.Value2)))
      dict(a.Value2) = a.Row ' 非首次出现，暂存当前行号待判断
    End If
  Next
  toDelete.Delete
End Sub

修正后可用代码 #

以下代码基于Dictionary对象编写，自动识别B列（header2列）的数据范围，20000行数据可秒级处理完成，无需手动选择区域，运行后自动保留每组重复值的首尾行，仅出现一次的数值不会被误删：

Sub KeepFirstLastOfDuplicates()
    Dim ws As Worksheet
    Dim lastRow As Long, i As Long
    Dim toDelete As Range
    Dim dict As Object
    Dim val As Variant
    Dim rowInfo As Variant
    
    ' 绑定目标工作表，可根据实际修改表名
    Set ws = Sheet1
    ' 自动获取B列最后一行行号
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    ' 初始化字典：key为B列单元格值，item存储两元素数组：[首次出现行号, 上一次出现行号]
    Set dict = CreateObject("Scripting.Dictionary")
    ' 初始化待删除范围，避免空值报错
    Set toDelete = ws.Rows(lastRow + 1)
    
    ' 关闭屏幕更新提升运行速度
    Application.ScreenUpdating = False
    
    ' 从第2行开始遍历（第1行为表头，可根据实际调整起始行）
    For i = 2 To lastRow
        val = ws.Cells(i, "B").Value2
        If Not dict.Exists(val) Then
            ' 第一次遇到该值，记录行号
            dict.Add val, Array(i, 0)
        Else
            rowInfo = dict(val)
            ' 如果上一次出现的行不是该值的首次出现行，加入待删除范围
            If rowInfo(1) > 0 And rowInfo(1) <> rowInfo(0) Then
                Set toDelete = Union(toDelete, ws.Rows(rowInfo(1)))
            End If
            ' 更新上一次出现的行号为当前行
            dict(val)(1) = i
        End If
    Next i
    
    ' 批量删除所有标记的行
    toDelete.Delete
    
    ' 恢复屏幕更新
    Application.ScreenUpdating = True
End Sub

使用提示：如果你的表头不在第1行、重复判断的列不是B列，直接修改代码中对应的起始行号、列标参数即可适配自己的表格。

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