Excel 用于副本的VBA（特殊需要）

我一直在找我要找的东西，但没有找到。这是令人沮丧的，因为我知道我不可能是唯一一个遇到这种情况的人

我有一个26k行的excel电子表格——我需要清除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是DEW和ABE，我想删除其中的5行。我不在乎5是什么，只剩下5个，剩下10个。

Tim Williams的评论将完全满足您的需求，比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

---

当这将数据拉入数组时，它将快速运行，但会用值覆盖表范围（公式将丢失）。我已经编写了一些自我描述的可选参数，允许您更改代码的行为。

在F2中，put

=COUNTIFS（D$2:D2，D2，E$2:E2，E2）>10

并填充。复制/粘贴F列中的值，然后删除colF=True的所有行谢谢！这就像冠军。我能把我的记录从26k降到15k。感谢这个模块——你是对的，Tim的快速过滤器工作得很好。

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