VBA delete the first 100 duplicates

[Mr Tran]

Hi,

I need a VBA code to delete the first 100 duplicates in column A and keep the remaining. There could be a thousand names that appear a thousand times, but would want to delete the first 100 duplicates that their name appear on this list and keep the remaining.

Thanks,

Mr Tran

 

[Rick Rothstein]

it would delete all of them so Mary would no longer be on the list

Untested (so you will have to verify), but I believe this macro should do what you want...

[table="width: 500"]
[tr]
	[td]Sub RemoveFirstOneHundredNames()
  Dim R As Long, V As Variant, Nmes As Variant
  Nmes = Range("A1", Cells(Rows.Count, "A").End(xlUp))
  With CreateObject("Scripting.Dictionary")
    For R = 1 To UBound(Nmes)
      If Left(.Item(Nmes(R, 1)), 1) <> "A" Then .Item(Nmes(R, 1)) = .Item(Nmes(R, 1)) + 1
      If .Item(Nmes(R, 1)) = 100 Then .Item(Nmes(R, 1)) = "A" & R
    Next
    For Each V In .Keys
      On Error Resume Next
      Range("A1:" & .Item(V)).Replace V, "#N/A", xlWhole, , False, , False, False
      If Err.Number Then Columns("A").Replace V, "#N/A", xlWhole, , False, , False, False
      On Error GoTo 0
    Next
  End With
  Columns("A").SpecialCells(xlConstants, xlErrors).EntireRow.Delete
End Sub[/td]
[/tr]
[/table]

 

[Akuini]

Just another way:

[FONT=lucida console][COLOR=Royalblue]Sub[/COLOR] a1090206b()
[I][COLOR=seagreen]'https://www.mrexcel.com/forum/excel-questions/1090206-vba-delete-first-100-duplicates.html[/COLOR][/I]

[COLOR=Royalblue]Dim[/COLOR] i [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]Long[/COLOR]
[COLOR=Royalblue]Dim[/COLOR] r [COLOR=Royalblue]As[/COLOR] Range
[COLOR=Royalblue]Dim[/COLOR] va, x
[COLOR=Royalblue]Dim[/COLOR] d [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]Object[/COLOR]

[COLOR=Royalblue]Set[/COLOR] d = CreateObject([COLOR=brown]"scripting.dictionary"[/COLOR]): d.CompareMode = vbTextCompare
[COLOR=Royalblue]Set[/COLOR] r = Range([COLOR=brown]"A1"[/COLOR], Cells(Rows.count, [COLOR=brown]"A"[/COLOR]).[COLOR=Royalblue]End[/COLOR](xlUp))
va = r
    [COLOR=Royalblue]For[/COLOR] i = [COLOR=crimson]1[/COLOR] [COLOR=Royalblue]To[/COLOR] UBound(va, [COLOR=crimson]1[/COLOR])
        x = va(i, [COLOR=crimson]1[/COLOR])
        [COLOR=Royalblue]If[/COLOR] d(x) < [COLOR=crimson]100[/COLOR] [COLOR=Royalblue]Then[/COLOR] d(x) = d(x) + [COLOR=crimson]1[/COLOR]: va(i, [COLOR=crimson]1[/COLOR]) = [COLOR=brown]""[/COLOR]
    [COLOR=Royalblue]Next[/COLOR]
r = va
r.SpecialCells(xlBlanks).EntireRow.Delete

[COLOR=Royalblue]End[/COLOR] [COLOR=Royalblue]Sub[/COLOR][/FONT]

If you want to delete the content only (not the row) then just delete this line:

r.SpecialCells(xlBlanks).EntireRow.Delete

 

[Rick Rothstein]

Just another way:

[FONT=lucida console][COLOR=Royalblue]Sub[/COLOR] a1090206b()
[I][COLOR=seagreen]'https://www.mrexcel.com/forum/excel-questions/1090206-vba-delete-first-100-duplicates.html[/COLOR][/I]

[COLOR=Royalblue]Dim[/COLOR] i [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]Long[/COLOR]
[COLOR=Royalblue]Dim[/COLOR] r [COLOR=Royalblue]As[/COLOR] Range
[COLOR=Royalblue]Dim[/COLOR] va, x
[COLOR=Royalblue]Dim[/COLOR] d [COLOR=Royalblue]As[/COLOR] [COLOR=Royalblue]Object[/COLOR]

[COLOR=Royalblue]Set[/COLOR] d = CreateObject([COLOR=brown]"scripting.dictionary"[/COLOR]): d.CompareMode = vbTextCompare
[COLOR=Royalblue]Set[/COLOR] r = Range([COLOR=brown]"A1"[/COLOR], Cells(Rows.count, [COLOR=brown]"A"[/COLOR]).[COLOR=Royalblue]End[/COLOR](xlUp))
va = r
    [COLOR=Royalblue]For[/COLOR] i = [COLOR=crimson]1[/COLOR] [COLOR=Royalblue]To[/COLOR] UBound(va, [COLOR=crimson]1[/COLOR])
        x = va(i, [COLOR=crimson]1[/COLOR])
        [COLOR=Royalblue]If[/COLOR] d(x) < [COLOR=crimson]100[/COLOR] [COLOR=Royalblue]Then[/COLOR] d(x) = d(x) + [COLOR=crimson]1[/COLOR]: va(i, [COLOR=crimson]1[/COLOR]) = [COLOR=brown]""[/COLOR]
    [COLOR=Royalblue]Next[/COLOR]
r = va
r.SpecialCells(xlBlanks).EntireRow.Delete

[COLOR=Royalblue]End[/COLOR] [COLOR=Royalblue]Sub[/COLOR][/FONT]

If you want to delete the content only (not the row) then just delete this line:

r.SpecialCells(xlBlanks).EntireRow.Delete

Use Akuini's code above instead of the code I posted as it will be faster.

 

[Mr Tran]

Thank you Akuini, Rick and Mike. This was most helpful.

Mr T.

 

[Akuini]

You're welcome, glad to help, & thanks for the feedback.