For all unique cells in a row, delete rows

Question

I need to delete the rows for all cells in column "E" that are unique, so I have only "NON-Unique" cells in column ie Column "E" has only duplicates.

I have been searching for code to do this but have found very little.

Sorry I cant even post a snip-it to start off with.

Thanks

Answer 1

Give this a try:

Sub RemoveUniques()
    Dim E As Range, rDel As Range, r As Range, N As Long
    N = Cells(Rows.Count, "E").End(xlUp).Row
    Set E = Range("E1:E" & N)
    Dim wf As WorksheetFunction
    Set wf = Application.WorksheetFunction
    Set rDel = Nothing
    For Each r In E
        v = r.Value
        If wf.CountIf(E, v) = 1 Then
            If rDel Is Nothing Then
                Set rDel = r
            Else
                Set rDel = Union(rDel, r)
            End If
        End If
    Next r

    If Not rDel Is Nothing Then
        rDel.EntireRow.Delete
    End If
End Sub