Delete Specific Cells based on Count

[Anthony1432]

Hi all, I'm after a macro that deletes all cells in column A, if they are duplicated more than 2 times (including the original 2).

For example:
Before:
A
1
2
2
3
3
3
3
4
4
4
After:
A
1
2
2

If tried a number of different loops but cant seem to write something that can search for multiple cell value counts above 2, and then delete them.

Thanks!

 

[JoeMo]

Try:

Sub RemoveCells()
Dim rng As Range, Lrw As Long, delRws As Range
Lrw = Range("A" & Rows.Count).End(xlUp).Row
Set rng = Range("A1", "A" & Lrw)
For Each c In rng
    If WorksheetFunction.CountIf(rng, c.Value) > 2 Then
        If delRws Is Nothing Then
            Set delRws = c
        Else
            Set delRws = Union(delRws, c)
        End If
    End If
Next c
If delRws Is Nothing Then
    MsgBox "No Column A entry is repeated more than twice"
Else
    delRws.Delete shift:=xlUp
End If

End Sub

 

[Anthony1432]

Thanks,

I changed a couple of things to make it relevant to the rest of my macro, worked perfectly!

Nice One!