删除重复的值，但保留行

Question

尝试创建宏以清除列中所有重复的值，但保留行

此方法有效，但保留了第一个副本。我只希望清除该列重复项中的任何内容。

    Dim lastRow As Long, i As Long
    Application.ScreenUpdating = False
        With Sheets("Sheet1")
            lastRow = .Cells(.Rows.Count, "E").End(xlUp).Row
            For i = lastRow To 1 Step -1
                If Application.CountIf(.Range("E1:E" & lastRow), .Range("E" & i)) > 1 Then
                .Range("E" & i).ClearContents
                End If
            Next i
        End With
    Application.ScreenUpdating = True

这是我的原始表单：

这就是我需要的：

Answer 1

我认为，最简单的方法是先存储要清除的所有单元格，然后再清除任何单元格，因为这会影响COUNTIF，最后一次完成所有操作。

Sub x()

Dim lastRow As Long, i As Long, r As Range

Application.ScreenUpdating = False

With Sheets("Sheet1")
    lastRow = .Cells(.Rows.Count, "E").End(xlUp).Row
    For i = lastRow To 1 Step -1
        If Application.CountIf(.Range("E1:E" & lastRow), .Range("E" & i)) > 1 Then
            If r Is Nothing Then
                Set r = .Range("E" & i)
            Else
                Set r = Union(r, .Range("E" & i))
            End If
        End If
    Next i
End With

If Not r Is Nothing Then r.ClearContents

Application.ScreenUpdating = True

End Sub

Answer 2

我将使用字典对象来收集需要清除的单元格：

Option Explicit
'Set Reference to Microsoft Scripting Runtime
Sub deDup()
    Dim wsSrc As Worksheet, rSrc As Range, C As Range
    Dim Dict As Dictionary, colRng As Collection
    Dim rDel As Range
    Dim v As Variant, w As Variant
    Dim sKey As String

'Set worksheet/range for the column to filter on
Set wsSrc = Worksheets("sheet2")
With wsSrc
    Set rSrc = .Range(.Cells(2, 5), .Cells(.Rows.Count, 5).End(xlUp))
End With

Set Dict = New Dictionary
    Dict.CompareMode = TextCompare

For Each C In rSrc
    sKey = C.Value2
    If Not Dict.Exists(sKey) Then
        Set colRng = New Collection
        colRng.Add C
        Dict.Add Key:=sKey, Item:=colRng
    Else
        Dict(sKey).Add C
    End If
Next C

For Each v In Dict.Keys
    If Dict(v).Count > 1 Then
        For Each w In Dict(v)
            If rDel Is Nothing Then
                Set rDel = w
            Else
                Set rDel = Union(rDel, w)
            End If
        Next w
    End If
Next v

rDel.Clear

End Sub

如果由于您的数据量太大而运行太慢，则可以

• 关闭ScreenUpdating，Events并将Calculation设置为manual
• 或将数据读入VBA阵列并以这种方式遍历数据。