CODEWITHSUNDEEP
vbaexcel
R S
R S

Reputation: 61

Delete Duplicate Cell Contents in Column

I am trying to delete the contents of duplicate cells in a single column. I want to keep the first occurrence of the entry, but remove all duplicates below it.

I could only find code that deletes the entire row and not clear the contents.

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

Upvotes: 2

Views: 1063

Answers (4)

Jayant Kumar jain
Jayant Kumar jain

Reputation: 27

    '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

Upvotes: 0

user3598756
user3598756

Reputation: 29421

my 0.02 cents

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

Upvotes: 2

Ron Rosenfeld
Ron Rosenfeld

Reputation: 60474

Here is a routine that will work. It can be sped up considerably if necessary:

EDIT: I changed column number to column letter, where you would need to make changes if you want a column other than "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

Upvotes: 1

Gary&#39;s Student
Gary&#39;s Student

Reputation: 96791

Here is one way. We start at the bottom of a column and work upwards:

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

We check above to see if there are any duplicates above us and clear the cell if yes. Before:

enter image description here

and after:

enter image description here

EDIT#1:

For column 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

Upvotes: 3

Related Questions