MrExcel Publishing
Your One Stop for Excel Tips & Solutions

For everyone who wants to delete duplicates in a column


Posted by Jacob on January 15, 2002 2:26 PM

This will do the trick

Option Explicit

Sub DeleteDuplicates()

Application.ScreenUpdating = False

Dim x As Integer
Dim LastRow As Integer
Dim c As Range
Dim FirstAddress As String
Dim SearchValue As String
Dim Counter As Integer

LastRow = Range("A65536").End(xlUp).Row

For x = 1 To LastRow

SearchValue = Range("A" & x).Value

If SearchValue = "zzzdeletemezzz" Then
Else

With Range("A1:A" & LastRow)

Set c = .Find(what:=SearchValue, LookIn:=xlValues, lookat:=xlWhole)
FirstAddress = c.Address
Set c = .FindNext(c)

If c.Address = FirstAddress Then
Else
Range(c.Address).FormulaR1C1 = "zzzdeletemezzz"
Counter = Counter + 1
End If

End With

End If

Next x

x = 1

Do

If Range("A" & x).Value = "zzzdeletemezzz" Then
Rows(x).Delete
LastRow = LastRow - 1
Else
x = x + 1
End If

Loop While x < LastRow + 1

MsgBox (Counter & " duplicates have been deleted."), vbInformation, "Deletion Complete"

End Sub


HTH

Jacob


Posted by Nate on January 15, 2002 2:37 PM

Smokin'

SearchValue = Range("A" & x).Value If SearchValue = "zzzdeletemezzz" Then Else With Range("A1:A" & LastRow) Set c = .Find(what:=SearchValue, LookIn:=xlValues, lookat:=xlWhole) FirstAddress = c.Address Set c = .FindNext(c) If c.Address = FirstAddress Then Else Range(c.Address).FormulaR1C1 = "zzzdeletemezzz" Counter = Counter + 1 End If End With End If Next x If Range("A" & x).Value = "zzzdeletemezzz" Then Rows(x).Delete LastRow = LastRow - 1 Else x = x + 1 End If Loop While x < LastRow + 1

Posted by Fluellen on January 15, 2002 4:00 PM

Or .....

..... avoiding the use of any loops :-

Sub DeleteDuplicates()
'Deletes rows with duplicates in Column A
Dim rng As Range
Application.ScreenUpdating = False
Columns("A:B").Insert
Set rng = Range(Range("C1"), Range("C65536").End(xlUp)).Offset(0, -2)
With Range("A1")
.Value = 1
.AutoFill Destination:=rng.Offset(0, -2), Type:=xlFillSeries
End With
With rng
.EntireRow.Sort Key1:=Range("C1"), Order1:=xlAscending, Header:=xlNo
.Offset(1, 1).FormulaR1C1 = "=IF(RC[1]&RC[2]=R[-1]C[1]&R[-1]C[2],1,"""")"
On Error Resume Next
.Offset(1, 1).SpecialCells(xlCellTypeFormulas, 1).EntireRow.Delete
.EntireRow.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlNo
.Resize(, 2).EntireColumn.Delete
End With
End Sub

Although the above code is not from the macro recorder, all of the actions performed by this macro can in fact be recorded with the macro recorder(and can work without any "tweaking") - knowledge of VBA is therefore not necessary (not so, if loops are used).

If anyone is interested, will post on request the manual way (macro-recordable) to delete duplicates from a column.

SearchValue = Range("A" & x).Value If SearchValue = "zzzdeletemezzz" Then Else With Range("A1:A" & LastRow) Set c = .Find(what:=SearchValue, LookIn:=xlValues, lookat:=xlWhole) FirstAddress = c.Address Set c = .FindNext(c) If c.Address = FirstAddress Then Else Range(c.Address).FormulaR1C1 = "zzzdeletemezzz" Counter = Counter + 1 End If End With End If Next x If Range("A" & x).Value = "zzzdeletemezzz" Then Rows(x).Delete LastRow = LastRow - 1 Else x = x + 1 End If Loop While x < LastRow + 1

Posted by Ivan F Moala on January 15, 2002 7:38 PM

Re: Or .....use Bob umlas amended macro (NT)

: This will do the trick : Option Explicit : Sub DeleteDuplicates() : Application.ScreenUpdating = False : Dim x As Integer : Dim LastRow As Integer : Dim c As Range : Dim FirstAddress As String : Dim SearchValue As String : Dim Counter As Integer : LastRow = Range("A65536").End(xlUp).Row : For x = 1 To LastRow : : SearchValue = Range("A" & x).Value : : If SearchValue = "zzzdeletemezzz" Then : Else : : With Range("A1:A" & LastRow) : : Set c = .Find(what:=SearchValue, LookIn:=xlValues, lookat:=xlWhole) : FirstAddress = c.Address : Set c = .FindNext(c) : : If c.Address = FirstAddress Then : Else : Range(c.Address).FormulaR1C1 = "zzzdeletemezzz" : Counter = Counter + 1 : End If : : End With : : End If : : Next x : x = 1 : Do : : If Range("A" & x).Value = "zzzdeletemezzz" Then : Rows(x).Delete : LastRow = LastRow - 1 : Else : x = x + 1 : End If : : Loop While x < LastRow + 1 : : MsgBox (Counter & " duplicates have been deleted."), vbInformation, "Deletion Complete" : End Sub : : HTH : Jacob

Posted by Fluellen on January 15, 2002 11:17 PM

Yes, that's better. And also .......

..... using Bob's formula, but avoiding the loop to make it macro-recordable :-

Sub DeleteDuplicates()
Dim rng As Range
Application.ScreenUpdating = False
Columns("A:A").Insert
Set rng = Range(Range("B1"), Range("B65536").End(xlUp)).Offset(0, -1)
With rng
.FormulaR1C1 = "=IF(COUNTIF(R1C2:RC[1],RC[1])>1,1,"""")"
On Error Resume Next
.SpecialCells(xlCellTypeFormulas, 1).EntireRow.Delete
.EntireColumn.Delete
End With
End Sub