VBA для дубликатов (необходимо указать c)

Question

Я обыскивал стекопоток и не нашел то, что искал. Что разочаровывает, потому что я знаю, что не могу быть единственным, кто сталкивался с этим.

У меня есть таблица Excel с 26k строками - и мне нужно очистить все строки, где столбцы D и E имеют одинаковые значения - за исключением того, что я хочу сохранить не более 10 строк и очистить остальные. В некоторых случаях будет только 3 повторяющихся строки, чтобы они могли остаться.

Вот пример моей электронной таблицы.

+------+-------+--------+---------+---------+
| 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     |
+------+-------+--------+---------+---------+

Представьте, что у меня было 15 строк, где места A и места B были РОСА и ABE - я хотел бы удалить 5 из них. Мне все равно, что 5, только 5 должны go, и мне нужно оставить с 10.

Answer 1

Комментарий Тима Уильямса сделает именно то, что вам нужно, и намного проще, чем решение VBA:

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

Если вы поместите приведенный выше код в модуль, вы можете записать приведенный ниже код в Командная кнопка или введите его в окно «Немедленное».

FilterRange Sheets("Sheet1").Range("A1:E26000"), Array(4, 5)

Поскольку данные вытягиваются в массив, они будут работать быстро, но будут перезаписывать диапазон таблицы значениями (формулы будут потеряны). Я написал несколько необязательных параметров с самоописанием, которые позволяют вам изменять поведение кода.