Question : Keep only duplicates in a given column and delete all Uniques

I have searched the DB of questions here and found only help on how to remove duplicate data. I am in need of scanning all 65k lines and delete all Unique rows. I am interested only in keeping the duplicate, triplicate, etc. data rows. I will search for duplicates in column 'K'. if K20000 and K20100 are equal, i would like to keep the those rows. All uniques to be removed.

Answer : Keep only duplicates in a given column and delete all Uniques

The following code will DEFINATELY solve your problem

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:



Sub DeleteUnique()
    Dim lRow As Long
    lRow = 2 'ASSUMING YOUR COLUMN HEADING IS IN FIRST ROW AND DATA IS STARTING FROM SECOND ROW
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    'Dim rng As Range, cell As Range
    'Set rng = Range("K:K" & Sheet1.UsedRange.Rows.Count)
    
    With Range("K2:K" & Sheet1.UsedRange.Rows.Count)
        Do While lRow <= .Rows.Count
            Debug.Print Cells(lRow, 11).Text & " - " & WorksheetFunction.CountIf(Range("K2:K" & Sheet1.UsedRange.Rows.Count), Cells(lRow, 11).Value)
            If WorksheetFunction.CountIf(Range("K2:K" & Sheet1.UsedRange.Rows.Count), Cells(lRow, 11).Value) = 1 Then
                Rows(lRow).delete
            End If
            lRow = lRow + 1
        Loop
    End With
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Open in New Window

Select All