删除重复值但保留行答案

【问题标题】：Delete duplicate values but leaves the rows删除重复值但保留行
【发布时间】：2019-10-27 08:52:34
【问题描述】：

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

这个有效，但它留下了第一个副本。我只想清除该列重复项中的任何内容。

    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

这是我原来的电子表格：

这是我需要的：

【问题讨论】：

标签： excel vba duplicates

【解决方案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

【讨论】：

我尝试使用 Set r = IIf(r Is Nothing, .Range("E" & i), Union(r, .Range("E" & i)))，我认为我曾在其他地方看到过使用但收到无效呼叫错误 - 如果有人有任何想法，会很高兴听到它们。
可以做一些稍微不同的事情，使用一个字符串来建立要删除的范围，即strDel = strDel & ",E" & i，然后在末尾Sheets("Sheet1").Range(right(strDel, len(strDel) - 1)).clearcontents。

【解决方案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 数组并以这种方式遍历数据。

【讨论】：