Remove Duplicates but keep one copy of each name

[Hyflex]

I'm looking for a macro to remove duplicates but to keep the first row where the duplicated name is found, I have hundreds and hundreds ofnames so I can't do it manually...

John Smith
Sarah Walker
Michael Bolin
Haley Adams
Josh McKell
Amy Wendle
Freddy Francis
Monty Fisher
Samual Eldrich
Michael Bolin
Amy Wendle
Melanie Roberts
Freddy Francis

Green = Unique Name = Keep
Brown = First Instance of Duplicated Name = Keep
Red = Duplicate = Delete

Any Suggestions?

Thanks in advance
- Hyflex

 

[Domenic]

If you're using Excel 2007 or later, you can easily remove duplicates without using VBA...

Data > Data Tools > RemoveDuplicates

 

[JoeMo]

And if you are pre-Excel 2007, try this:

Sub RemoveDuplicateItems()
'This module removes duplicates from a user-selected range
'after trimming all leading and trailing spaces from non-formulaic cells in the range.
Dim cl As Range, cUnique As New Collection, evalRng As Range
Dim msg As String, K As Long, ctr As Long, totCells As Long

msg = "Select the range you want to remove duplicate items from."
On Error Resume Next
Set evalRng = Application.InputBox(msg, Type:=8)
If Err.Number <> 0 Then Exit Sub 'Cancel was clicked or a valid range wasn't selected.
On Error GoTo 0
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

totCells = evalRng.Cells.Count
Call TrimRangeOfCells(evalRng)
ctr = 0
    On Error Resume Next  'An error occurs whenever an item to be added
    'duplicates one that is already in the collection
    For Each cl In evalRng
        If cl.Formula <> "" Then
            cUnique.Add cl.Value, CStr(cl.Value)
            If Err.Number <> 0 Then  'This cell is a duplicate of one already added
                ctr = ctr + 1
                cl.ClearContents  'Make cell a blank
                Err.Number = 0
            End If
        End If
    Next cl
evalRng.SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
If Err.Number <> 0 Then
    MsgBox "There are no duplicates in this range."
    Exit Sub
End If
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
msg = ctr & " duplicate cells were deleted from a total of " & totCells & " cells."
MsgBox msg
evalRng.Cells(1, 1).Select
End Sub
Sub TrimRangeOfCells(rng As Range)
 'Purpose is to trim leading & trailing spaces form non-formulaic cells
 'in a the user-selected range which need not be contiguous.
 Dim cell As Range, constCells As Range
 Dim NumConstCells As Long, totCells As Long
 Dim ctr As Long
 
 totCells = rng.Count
 On Error Resume Next
 Set constCells = rng.SpecialCells(xlCellTypeConstants)
 NumConstCells = constCells.Count

For Each cell In constCells
cell = Trim(cell)
Next cell
End Sub

 

[jeffreybrown]

Or this...

Sub Del()
    Dim LR As Long: LR = Range("A" & Rows.Count).End(xlUp).Row
    ActiveSheet.Range("A1:A" & LR).RemoveDuplicates Columns:=1, Header:=xlNo
End Sub

Edit: Change Header:=xlNo to xlYes if you have a header

 

[brettdj]

Another option is my (free) Duplicate Master addin, available for download at http://www.experts-exchange.com/A_2123.html

It will either clear or delete completely any duplicate cells or rows
With the option of retaining the first value

hth

Dave

 

[iamgujju]

Hello Mate,

i am newbie here and first of all i am sorry to bother you.

i have used code, which you have provided here but i would like to keep last row rather than 1st row if column "a" contains duplicate data

i hope this make sense - when i am using your code - its deleting data but keeping the 1st one but i need the last one to be kept.

any help is much aprpeciated.

Regards,
Iamgujju

Or this...

Sub Del()
    Dim LR As Long: LR = Range("A" & Rows.Count).End(xlUp).Row
    ActiveSheet.Range("A1:A" & LR).RemoveDuplicates Columns:=1, Header:=xlNo
End Sub

Edit: Change Header:=xlNo to xlYes if you have a header

 

[iamgujju]

i am looking for something other way round for duplicates.

unique can stay as it is but duplicate - the last one keep and the first one to be removed

I'm looking for a macro to remove duplicates but to keep the first row where the duplicated name is found, I have hundreds and hundreds ofnames so I can't do it manually...

John Smith
Sarah Walker
Michael Bolin
Haley Adams
Josh McKell
Amy Wendle
Freddy Francis
Monty Fisher
Samual Eldrich
Michael Bolin
Amy Wendle
Melanie Roberts
Freddy Francis

Green = Unique Name = Keep
Brown = First Instance of Duplicated Name = Keep
Red = Duplicate = Delete

Any Suggestions?

Thanks in advance
- Hyflex

 

[JoeMo]

i am looking for something other way round for duplicates.

unique can stay as it is but duplicate - the last one keep and the first one to be removed

This is for a single column list like the names list you referred to in your post.

Sub RemoveFirstDupLeaveLast()
'assumes a single vertical or horizontal list
Dim d As Object, R As Range, i As Long, delRw As Range
On Error Resume Next
Set R = Application.InputBox("Select the range you want to remove duplicates from with your mouse", Type:=8)
On Error GoTo 0
If R Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.dictionary")
For i = R.Count To 1 Step -1
    If d.exists(R(i).Value) Then
        If delRw Is Nothing Then
            Set delRw = R(i)
        Else
            Set delRw = Union(delRw, R(i))
        End If
    Else
        d.Add R(i).Value, d.Count + 1
    End If
Next i
If Not delRw Is Nothing Then delRw.Delete shift:=xlUp
Application.ScreenUpdating = True
End Sub

 

[iamgujju]

Thanks a lot for your help.

 

[JoeMo]

Thanks a lot for your help.

You are welcome - thanks for the reply.