How to keep only 10 duplicates?

[jfleig1]

Hi,

I have a bunch of phone numbers in a row and I want to eliminate duplicates of 10 for a given number. For example - 5556839898 may appear 15 times, I want to delete the 5 extra instances of that number, leaving me with a maximum of 10 duplicates. This is for an SMS voting application where the entries where supposed to be limited to 10x.

Thanks!

 

[Weaver]

Would it be easier to count the entries and apply a ceiling of 10 to the results?

 

[mikerickson]

How is your data layed out and which of the 15 duplicates should be saved and which removed?

 

[MickG]

Hi, Try this :- Your Data in row (1), Results in Row(3)

Sub ten()
Dim Rng As Range, Dn As Range
Dim n As Long, Ray, Q
n = 1
Set Rng = Range(Range("A1"), Cells(1, Columns.Count).End(xlToLeft))
ReDim Ray(1 To Rng.Count)
With CreateObject("scripting.dictionary")
    .comparemode = vbTextCompare
    For Each Dn In Rng
          If Dn.Value <> "" And Not .Exists(Dn.Value) Then
             .Add Dn.Value, 1
             Ray(n) = Dn.Value
         ElseIf Not .Item(Dn.Value) >= 11 Then
            n = n + 1
            Q = .Item(Dn.Value)
            Q = Q + 1
             .Item(Dn.Value) = Q
             Ray(n) = Dn.Value
         End If
     Next
Range("A3").Resize(, .Count + n).Value = Ray
End With
End Sub

Regards Mick

 

[jfleig1]

Thanks Guys!

My data is formatted well: ~60,000 rows of 10 digit phone numbers all in Column A...

 

[mikerickson]

If there are more than 10 duplicate phone numbers, do you want to keep the topmost 10 or the 10 bottommost of those duplicates?

 

[jfleig1]

I would like to keep all phone numbers, with a limit of no more than 10 duplicates per number. Right now ~10% of the numbers have more than 10 instances.

 

[mikerickson]

If there are 20 instances of the phone number 123-456-7089, which of those should be deleted and which removed?

Or is this a single list of phone numbers with no other data on the sheet?

 

[VoG]

If you want to delete from the bottom up try

Sub maxten()
Dim LR As Long, i As Long
LR = Range("A" & Rows.Count).End(xlUp).Row
For i = LR To 1 Step -1
    If WorksheetFunction.CountIf(Columns("A"), Range("A" & i).Value) > 10 Then Rows(i).Delete
Next i
End Sub

 

[facethegod]

this should delete from top..

Sub tst2()
Dim r As Range
Columns(1).Insert
Set r = Range("A1:A" & Cells(Rows.Count, 2).End(xlUp).Row)
r.Formula = "=IF(COUNTIF(R1C2:RC[1],RC[1]:RC[1])>=10,NA(),RC[1])"
r.SpecialCells(xlCellTypeFormulas, xlErrors).EntireRow.Delete
Columns(1).Delete
End Sub