Delete duplicates

[av8tordude]

I need a code that will find any duplicates cities in column B and delete the city and the entire row of that duplicate city that is to be deleted, leaving only one set

Example:

Alabama | Gulf Shores | Baldwin | ...
Alabama | Gulf Shores | Baldwin | ...
Arizona | Grand Canyon | Coconino| ...
Arizona | Grand Canyon | Coconino| ...
Arizona | Grand Canyon | Coconino| ...

Results:

Alabama | Gulf Shores | Baldwin | ...
Arizona | Grand Canyon | Coconino| ...

[av8tordude]

I found a resolution to my problem.

http://www.vbaexpress.com/kb/getarticle.php?kb_id=135

[GTO]

Hi Aviator,

I note that there is differing info the the columns past C. Do we care which record is retained?

Mark

[av8tordude]

Hi GTO,

No, I was only concerned about deleting the duplicates. Thank you for checking.

On another note, could you help with a code that will lookup the County in column V and insert the County into column S for the City & State (Column Q & R)

[av8tordude]

anyone?

Also, is it possible to look at column B & C (City & County) to find duplicates and then delete the row? What I discovered, some Cities listed have similar County names.

Example

Durham, Durham
&
Durham, Strafford

I've tried the code below, but it definitely did not like that.


Sub DeleteDups()
Dim x As Long, LastRow As Long
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
For x = LastRow To 1 Step -1
If Application.WorksheetFunction.CountIf(Range("B1:C" & x), Range("B:C" & x).Text) > 1 Then
Range("B:C" & x).EntireRow.Delete
End If
Next x
End Sub

[mancubus]

i use below procedure to delete duplicates based on multiple columns.
(in this example cols A, B and C)




Sub DelDupRows()
Dim LR As Long, rww As Long
Dim dic As Object
Dim ws As Worksheet
Application.ScreenUpdating = False
Set dic = CreateObject("Scripting.Dictionary")
Set ws = ActiveSheet
LR = ws.Range("A" & Rows.Count).End(xlUp).Row
rww = 2
While rww <= LR
If dic.exists(ws.Range("A" & rww).Value & ws.Range("B" & rww).Value _
& ws.Range("C" & rww).Value) Then
ws.Rows(rww).Delete shift:=xlUp
LR = LR - 1
Else
dic.Add ws.Range("A" & rww).Value & ws.Range("B" & rww).Value _
& ws.Range("C" & rww).Value, 1
rww = rww + 1
End If
Wend
Application.ScreenUpdating = True
End Sub