how to filter to KEEP duplicate records

[farful]

Hi,
I have a sorted column. I want to remove all singletons from this list, and keep duplicates (and triplicates, quadruplicates, etc).
How can I achieve this?
(VBA method is fine - I'm looking for either something already built into Excel, or something efficient if done in VBA)
Thanks!

 

[jbeaucaire]

Use this macro, it is deleting based on the values in column A (skipping the titles in row1). Change that if you need to:

Option Explicit
Sub DeleteSingles()
Dim lastrow As Long
lastrow = Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False

    Columns("B:B").Insert Shift:=xlToRight
    Range("B2:B" & lastrow).FormulaR1C1 = "=COUNTIF(R2C1:R26C1,RC[-1])>1"
    Range("A1").AutoFilter
    Range("A1").AutoFilter Field:=2, Criteria1:="=FALSE", Operator:=xlAnd
    Range("A2:B" & lastrow).EntireRow.Delete
    Range("A1").AutoFilter
    Columns("B:B").Delete Shift:=xlToLeft

Application.ScreenUpdating = True
End Sub

 

[farful]

Awesome, thanks!

Should change to:
Range("B2:B" & lastrow).FormulaR1C1 = "=COUNTIF(C1:C1,RC[-1])>1"

 

[farful]

Actually, this does not take advantage of the fact that my list is already sorted - is there any way to improve the run time using this fact?

 

[jbeaucaire]

No, the autofilter is doing all the heavy lifting in one step, I'm not sure how to improve on THAT. Impatient, are we? Hehe, how many rows of data are we talking about?

Well, let's see if this is any help:

Option Explicit
Sub DeleteSingles()
Dim lastrow As Long
lastrow = Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False

    Columns("B:B").Insert Shift:=xlToRight
    Range("B2:B" & lastrow).FormulaR1C1 = "=COUNTIF(R2C1:R26C1,RC[-1])>1"
        
    Application.Calculation = xlCalculationManual
    Range("A1").AutoFilter
    Range("A1").AutoFilter Field:=2, Criteria1:="=FALSE", Operator:=xlAnd
    Range("A2:B" & lastrow).EntireRow.Delete
    Range("A1").AutoFilter
    Columns("B:B").Delete Shift:=xlToLeft
    Application.Calculation = xlCalculationAutomatic
    
Application.ScreenUpdating = True
End Sub