How to keep only 10 duplicates?

jfleig1

New Member
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!

Excel Facts

Copy PDF to Excel
Select data in PDF. Paste to Microsoft Word. Copy from Word and paste to Excel.

Weaver

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

mikerickson

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

MickG

MrExcel MVP
Hi, Try this :- Your Data in row (1), Results in Row(3)
Code:
``````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
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

New Member
Thanks Guys!

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

mikerickson

MrExcel MVP
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

New Member
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

MrExcel MVP
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

Legend
If you want to delete from the bottom up try

Code:
``````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

Well-known Member
this should delete from top..

Code:
``````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``````

Replies
3
Views
182
Replies
0
Views
321
Replies
2
Views
358
Replies
3
Views
182
Replies
4
Views
466

1,191,366
Messages
5,986,242
Members
440,012
Latest member
StumpedGump1987

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back