VBA for Duplicates (specific need) - excel

Question

I've been scouring stackoverflow and haven't found what I am looking for. Which is frustrating because I know I can't be the only one who has come across this.
I have an excel spreadsheet with 26k rows -- and I need to purge all rows where column D and E have same values -- except I want to keep at most 10 rows and purge rest. In some instances there will only be 3 duplicate rows so those can stay.
Here is example of my spreadsheet.
+------+-------+--------+---------+---------+
| Code | Local | Number | Place A | Place B |
+------+-------+--------+---------+---------+
| A | 558 | 25 | DEW | ABE |
+------+-------+--------+---------+---------+
| A | 485 | 14 | DEW | FXD |
+------+-------+--------+---------+---------+
| A | 658 | 85 | DEW | ABE |
+------+-------+--------+---------+---------+
| A | 225 | 68 | ABE | FXD |
+------+-------+--------+---------+---------+
| A | 1 | 56 | ABE | FXD |
+------+-------+--------+---------+---------+
| A | 47 | 412 | DEW | CDE |
+------+-------+--------+---------+---------+
Imagine I had 15 rows where Place A and Place B were DEW and ABE -- I would want to delete 5 of those. I don't care what 5, just 5 have to go and I need to be left with 10.

Answer 1

Tim Williams' comment will do exactly what you're after and is far simpler than a VBA solution:
Public Sub FilterRange(ByRef TargetTable As Range, ByVal TargetColumns As Variant, Optional ByVal MaxDuplicateCount As Long = 10, _
Optional ByVal IsCaseSensitive As Boolean = False, Optional ByVal Delimiter As String = "^&")
Dim Temp As Variant, x As Long, y As Long
'Error checking
If Not IsArray(TargetColumns) Then
MsgBox "Target columns must be provided as a one dimensional array i.e. ""Array(1, 4, 5)"" ", vbCritical
Exit Sub
End If
'More error checking
For x = 0 To UBound(TargetColumns, 1)
If Not IsNumeric(TargetColumns(x)) Then
MsgBox "Invalid column number supplied: " & TargetColumns(x), vbCritical
Exit Sub
ElseIf TargetColumns(x) < 1 Then
MsgBox "Invalid column number supplied: " & TargetColumns(x), vbCritical
Exit Sub
ElseIf TargetColumns(x) > TargetTable.Columns.Count Then
MsgBox "Invalid column number supplied: " & TargetColumns(x), vbCritical
Exit Sub
End If
Next x
'Create Dictionary object
Dim DuplicateCounter As Object, ThisRowVal As Variant
Set DuplicateCounter = CreateObject("Scripting.Dictionary")
'Set Dictionary case sensitivity
If IsCaseSensitive Then
DuplicateCounter.CompareMode = 0
Else
DuplicateCounter.CompareMode = 1
End If
'Pull table into an array
Temp = TargetTable.Value
'Check each row in the array
For x = 1 To UBound(Temp, 1)
'Determine this row's unique value (based on the supplied columns)
ThisRowVal = Empty
For y = 0 To UBound(TargetColumns, 1)
ThisRowVal = ThisRowVal & Temp(x, TargetColumns(y)) & Delimiter
Next y
'Check for duplicates
If DuplicateCounter.Exists(ThisRowVal) Then
If DuplicateCounter(ThisRowVal) >= MaxDuplicateCount Then
'Too many with this unique value, delete the excess row data
For y = 1 To UBound(Temp, 2)
Temp(x, y) = Empty
Next y
Else
'We haven't exceeded the max row count: increment the counter
DuplicateCounter(ThisRowVal) = DuplicateCounter(ThisRowVal) + 1
End If
Else
'This value is new: add to dictionary with a count of 1
DuplicateCounter.Add ThisRowVal, 1
End If
Next x
'Write the output data to the table range
TargetTable.Value = Temp
End Sub
If you put the above code into a module, you can write the below into a command button, or type it into the Immediate window.
FilterRange Sheets("Sheet1").Range("A1:E26000"), Array(4, 5)
As this pulls the data into an array, it will operate quickly, but will overwrite the table range with values (formulas will be lost). I've written some self-describing optional parameters that allow you to change the code's behaviour.