删除列中的重复单元格内容

Question

我正在尝试删除单个列中重复单元格的内容。我想保留第一次出现的条目，但删除它下面的所有重复项。

我只能找到删除整行而不清除内容的代码。

Sub Duplicate()

With Application
    ' Turn off screen updating to increase performance
    .ScreenUpdating = False
    Dim LastColumn As Integer
    LastColumn = Cells.Find(What:="*", After:=Range("U1"), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
    With Range("U1:U" & Cells(Rows.Count, 1).End(xlUp).Row)
        ' Use AdvanceFilter to filter unique values
        .AdvancedFilter Action:=xlFilterInPlace, Unique:=True
        .SpecialCells(xlCellTypeVisible).Offset(0, LastColumn - 1).Value = 1
        On Error Resume Next
        ActiveSheet.ShowAllData
        'Delete the blank rows
        Columns(LastColumn).SpecialCells(xlCellTypeBlanks).Cells.Clear
        Err.Clear
    End With
    Columns(LastColumn).Clear
    .ScreenUpdating = True
End With

End Sub

Answer 1

这是一种方法。我们从列的底部开始向上工作：

Sub RmDups()
    Dim A As Range, N As Long, i As Long, wf As WorksheetFunction
    Dim rUP As Range

    Set A = Range("A:A")
    Set wf = Application.WorksheetFunction

    N = Cells(Rows.Count, "A").End(xlUp).Row

    For i = N To 2 Step -1
        Set rUP = Range(Cells(i - 1, 1), Cells(1, 1))
        If wf.CountIf(rUP, Cells(i, 1).Value) > 0 Then Cells(i, 1).Clear
    Next i
End Sub

我们检查上面是否有任何重复项，如果是，请清除单元格。之前：

之后：

修改＃1：

列 U ：

Sub RmDupsU()
    Dim U As Range, N As Long, i As Long, wf As WorksheetFunction
    Dim rUP As Range

    Set U = Range("U:U")
    Set wf = Application.WorksheetFunction

    N = Cells(Rows.Count, "U").End(xlUp).Row

    For i = N To 2 Step -1
        Set rUP = Range(Cells(i - 1, "U"), Cells(1, "U"))
        If wf.CountIf(rUP, Cells(i, "U").Value) > 0 Then Cells(i, "U").Clear
    Next i
End Sub

Answer 2

我的0.02美分

Sub main()
    Dim i As Long
    With Range("A1", Cells(Rows.Count, 1).End(xlUp))
        For i = 1 To .Rows.Count - 1
            .Range(.Cells(i + 1, 1), .Cells(.Rows.Count)).Replace what:=.Cells(i, 1).Value, replacement:="", lookat:=xlWhole
        Next i
    End With
End Sub

Answer 3

这是一个可行的例程。如有必要，它可以大大加快：

编辑：我将列号更改为列号，如果您想要“A”以外的列，则需要进行更改

Option Explicit
Sub ClearDups()
    Dim R As Range
    Dim I As Long
    Dim COL As Collection

Set R = Range(Cells(1, "A"), Cells(Rows.Count, "A").End(xlUp))
Set COL = New Collection

On Error Resume Next
For I = 1 To R.Rows.Count
    COL.Add Item:=R(I, 1), Key:=CStr(R(I, 1))
    Select Case Err.Number
        Case 457 'Duplicate test (Collection object rejects duplicate keys)
            Err.Clear
            R(I, 1).ClearContents
        Case Is <> 0  'unexpected error
            MsgBox Err.Number & vbLf & Err.Description
    End Select
Next I
On Error Goto 0


End Sub

Answer 4

    'This code crisply does the job of clearing the duplicate values in a given column
    Sub jkjFindAndClearDuplicatesInGivenColumn()
        dupcol = Val(InputBox("Type column number"))
        lastrow = Cells(Rows.Count, dupcol).End(xlUp).Row
        For n = 1 To lastrow
        nval = Cells(n, dupcol)
            For m = n + 1 To lastrow
            mval = Cells(m, dupcol)
                If mval = nval Then
                Cells(m, dupcol) = ""
                End If
            Next m
        Next n
    End Sub