Remove duplicates if it appears more than 20 times

[paldob]

Good Afternoon,

I have an excel spreadsheet that contacts multiple columns of data.

Column 1 ("A2:A" & Lastrow) contains names of the person who complete the data.

Each name is duplicated over 200+ times, however - I only want to show the first 15 of each person and for the remaning 185+ to be deleted.

I have 17 names and want only 15 rows for each person to be kept - so I will end up with 255 rows (256 including title) after the routine has complete.

I have sorted column A by Names in order but I'm struggling to think of a loop or a routine to do the above.

I currently have the below routines to tidy the data - I'm just missing the above part to finalise my worksheet

Sub SortQualityData()
Dim Lastrow As Long

    With Sheets("Completed")
    Lastrow = Sheets("Completed").Range("A1048576").End(xlUp).Row
    
        .Cells.AutoFilter
        
        'Copy Names
        .Range("C3:C" & Lastrow).Copy
        'Paste Names into Sort Column
        .Range("BW3").PasteSpecial xlPasteValues
        'Input RANDBETWEEN formula into blank column
        .Range("BV3:BV" & Lastrow).Formula = "=RANDBETWEEN(1, 2000)"
        'Copy Paste Value the Formulas
        .Range("BV3:BV" & Lastrow).Copy
        .Range("BV3").PasteSpecial xlPasteValues
        'Filter Quality Control to Blanks
        .Range("$A$2:$CI" & Lastrow).AutoFilter Field:=79, Criteria1:="="
        
        .Range("A2:CI" & Lastrow).Copy
        
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Data"
        
        Application.DisplayAlerts = False
        
        Sheets("Data").Range("A1").PasteSpecial xlPasteValues
        
        .Cells.AutoFilter
       
    End With
       
End Sub
Sub DataSort()
Dim Lastrow As Long
Lastrow = Sheets("Data").Range("A1048576").End(xlUp).Row
    'Sort by Name and by RANDBETWEEN Formula
    With Sheets("Data")
        .Range("A1:CI" & Lastrow).Select
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=Range("C2:C" & Lastrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=Range("BV2:BV" & Lastrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SetRange Range("A1:CI" & Lastrow)
        .Sort.Header = xlYes
        .Sort.MatchCase = False
        .Sort.Orientation = xlTopToBottom
        .Sort.SortMethod = xlPinYin
        .Sort.Apply
    End With
End Sub

 

[Fluff]

How about

Sub delSomeRws()
   Dim Cl As Range, Rng As Range
   Dim Dic As Object
   
   Set Rng = Range("A" & Rows.Count).End(xlUp).Offset(1)
   Set Dic = CreateObject("scripting.dictionary")
   For Each Cl In Range("A2", Range("A" & Rows.Count).End(xlUp))
      Dic(Cl.Value) = Dic(Cl.Value) + 1
      If Dic(Cl.Value) > 15 Then Set Rng = Union(Cl, Rng)
   Next Cl
   If Not Rng Is Nothing Then Rng.EntireRow.Delete
End Sub