Deleting duplicate entries

[jmosk]

I am wondering if anyone can help. I have this VB script below tha
deleted duplicates. But I want to know how to make it only look i
column F and then delete any dups it finds.

Can anyone help, please?

Sub DeleteDuplicatesAnyCol()
Dim sht As Worksheet, sht2 As Worksheet
Dim rng As Range
Dim fndrng As Range
Dim mycell
Dim lookupcol As Integer, i As Integer
lookupcol = 1 ' for example Column E - replace with 1 if you want to g
with Column A
Set sht = ActiveSheet
Set rng = sht.Range(sht.Cells(1, lookupcol), sht.Cells(65536
lookupcol).End(xlUp))
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set sht2 = Worksheets.Add
sht2.Name = "Deleted"
i = 1
sht.Activate
For Each mycell In rng.Cells
Set fndrng = rng.Find(mycell.Value, mycell, xlValues, xlWhole)
Do Until fndrng.Row = mycell.Row
sht.Rows(fndrng.Row).Copy Destination:=sht2.Rows(i)
i = i + 1
sht.Rows(fndrng.Row).Delete
Set fndrng = rng.FindNext(mycell)
Loop
Next mycell
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Su

 

[jmosk]

Also, I need to make sure that it still deletes the whole entry

 

[Tom Ogilvy]

Change LookupCol = 5

Sub DeleteDuplicatesAnyCol()
Dim sht As Worksheet, sht2 As Worksheet
Dim rng As Range
Dim fndrng As Range
Dim mycell
Dim lookupcol As Integer, i As Integer
lookupcol = 5 ' for example Column F -
' replace with 1 if you want
' to go with Column A
Set sht = ActiveSheet
Set rng = sht.Range(sht.Cells(1, lookupcol), sht.Cells(65536,
lookupcol).End(xlUp))
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set sht2 = Worksheets.Add
sht2.Name = "Deleted"
i = 1
sht.Activate
For Each mycell In rng.Cells
Set fndrng = rng.Find(mycell.Value, mycell, xlValues, xlWhole)
Do Until fndrng.Row = mycell.Row
sht.Rows(fndrng.Row).Copy Destination:=sht2.Rows(i)
i = i + 1
sht.Rows(fndrng.Row).Delete
Set fndrng = rng.FindNext(mycell)
Loop
Next mycell
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

 

[Tom Ogilvy]

If it worked as you wanted before, it should still do so.

 

[jmosk]

I still don't know how to execute the script on Column F though.

Just putting 6 in place of 1 in lookupcol=

gives me a runtime error

 

[Tom Ogilvy]

Sub DeleteDuplicatesAnyCol()
Dim sht As Worksheet, sht2 As Worksheet
Dim rng As Range
Dim fndrng As Range
Dim mycell
Dim lookupcol As Integer, i As Integer
lookupcol = 6 ' for example Column F -
' replace with 1 if you want
' to go with Column A
Set sht = ActiveSheet
Set rng = sht.Range(sht.Cells(1, lookupcol), _
sht.Cells(65536, lookupcol).End(xlUp))
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set sht2 = Worksheets.Add
sht2.Name = "Deleted"
i = 1
sht.Activate
For Each mycell In rng.Cells
Set fndrng = rng.Find(mycell.Value, mycell, xlValues, xlWhole)
Do Until fndrng.Row = mycell.Row
sht.Rows(fndrng.Row).Copy Destination:=sht2.Rows(i)
i = i + 1
sht.Rows(fndrng.Row).Delete
Set fndrng = rng.FindNext(mycell)
Loop
Next mycell
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Worked fine for me. (I made no modification except changed 5 to 6).

I did break on long line into 2 with a line continuation character, Maybe
you were the victim of wordwrap if you copied it from the email.

 

[jmosk]

i can set the value to 1-5and it works fine. but not 6 or higher withou
an error.

I dont get it.