Delete Duplicate Row

[Hoopsah]

Hi

does anyone have a macro that will check all rows in column D and delete any duplicates?

[RonMcK]

Hoopsah,

Have you looked in the Knowledge Base (KBase in toolbar, above) and/or search the threads, here?

Cheers!

[Bob Phillips]

Does delete trhe cell mean blank out the contents, or shunt the rets of the row one cell left?

[RonMcK]

Or, do you want to delete the entire row whenever cell D[this row] equals (is identical to the value of cell D[any preceding row]?

Cheers,

[Hoopsah]

Hi

I was hoping to delete the row below completely.

I have now completed the task by putting a formula in column E simply doing a =IF(D2=D1,"DUP",0)

Then simply deleted anything that had DUP there and so on.

But going forward it would be nice to know if there was a macro that could do this

Cheers

[Bob Phillips]

Sub Deletedups()
Dim LastRow As Long
Dim rng As Range
With ActiveSheet
LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
        .Columns("E").Insert
        .Range("E1").Value = "Flag"
        .Range("E2").Resize(LastRow - 1).Formula = "=IF(D2=D1,""DUP"","""")"
        Set rng = .Columns("E")
        rng.AutoFilter Field:=1, Criteria1:="DUP"
On Error Resume Next
        Set rng = .Range("E1").Resize(LastRow - 1).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        If Not rng Is Nothing Then rng.EntireRow.Delete
        .Columns("E").Delete
    End With
End Sub

[georgiboy]

Heres one that would just delete the rows based on the duplicates found in column "D"

Sub DelDups()
Dim Col As Integer
Dim r As Long
Dim C As Range
Dim V As Variant
Dim Rng As Range
On Error GoTo EndSub
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set Rng = Range("D1:D" & Range("D65536").End(xlUp).Row)
For r = Rng.Rows.Count To 1 Step -1
    V = Rng.Cells(r, 1).Value
    If V = "" Then Rng.Rows(r).EntireRow.Delete
    If Application.WorksheetFunction.CountIf(Rng.Columns(1), V) > 1 Then
        Rng.Rows(r).EntireRow.Delete
    End If
Next r
EndSub:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Hope this helps

[Hoopsah]

Works Perfectly!

Thanks guys I have now saved this macro to my own library - one of these days someone will ask me to do this chore again - lol

Cheers