excel - VBA:保留Excel工作表的第一行和最后一行重复列值

Question

我有一个包含 20K 行的 Excel 工作表，如下所示:


标题1
header 2


1
磷

2
磷

3
磷

4
问

5
R

6
R

7
R

8
R

9
小号

10
小号


我想要一个 VBA 代码来删除包含重复的行，但是 保留第一行和最后一行的重复项。结果应该是这样的:


标题1
header 2


1
磷

3
磷

4
问

5
R

8
R

9
小号

10
小号


我修改了以下代码发现here为此，但每次我必须手动选择包含列 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
                    'this value exists again in the range
                    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

找到另一个代码 here由用户 A.S.H.使用 Dictionary 自动进行手动选择和速度，但无法产生想要的结果。

Sub keepFirstAndLast()
  Dim toDelete As Range: Set toDelete = Sheet1.Rows(999999) '(to not start with a null range)
  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 ' first appearence, dont save the row
    Else
      ' if last observed occurrence was a duplicate, add it to deleted range
      If dict(a.Value2) > 0 Then Set toDelete = Union(toDelete, Sheet1.Rows(dict(a.Value2)))
      dict(a.Value2) = a.row ' not first appearence, save the row for eventual deletion
    End If
  Next
  toDelete.Delete
End Sub

Answer 1

简单的解决方案:

Sub KeepFirstLast()

Application.ScreenUpdating = False

Dim lastRow As Long
lastRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
Dim i As Long
Dim x As Long
Dim currentValue As String

For i = lastRow To 2 Step -1
    If i = 2 Then
        Application.ScreenUpdating = True
        Exit For
    End If
    currentValue = Sheets(1).Cells(i, 2).Value
    x = i - 1
    Do While Sheets(1).Cells(x, 2).Value = currentValue And Sheets(1).Cells(x - 1, 2).Value = currentValue
        Sheets(1).Rows(x).Delete
        x = x - 1
    Loop
    i = x + 1
Next i


Application.ScreenUpdating = True

End Sub