Delete Duplicate Cell Contents in Column - vba

Question

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

Answer 1

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:
and after:
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

Answer 2

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

Answer 3

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

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