删除重复的 EXCEL VBA 宏

Question

我需要一些关于宏的帮助，我什至不知道从哪里开始，因为我对此很陌生。我将在从“A7”开始的“A”列中列出数据/参考编号。许多这些 Ref 编号将有重复。 （主要是2个重复）

虽然，在某些情况下，我会有 3 或 4 个相同 Ref 编号的副本。我需要一个宏来搜索出现两次以上的“A”列中的重复值并删除它们以及它们所在的行，同时保留第一个和最后一个实例。

我希望我解释得足够清楚，可以理解。我附上了下面示例的快照。

“A”到“C”列包含一个数据集，其中包含重复项，其中一个实例有 3 个。 （以红色文本突出显示）我想要的最终结果显示在“G”到“I”列中。

请注意，这需要使用宏/VBA 来完成，并且每次运行此宏时列和行中的数据长度可能会有所不同，因此它需要应用到最后使用的行和列。

任何帮助将不胜感激！

这是我应用的基本脚本，但问题是它会删除所有重复项。 子复制()

M = Cells(Rows.Count, "A").End(xlUp).Row

For i = M To 7 Step -1
        Set rlook = Range(Cells(i - 1, "A"), Cells(7, 1))
        If Application.WorksheetFunction.CountIf(rlook, Cells(i, "A")) > 0 Then
            Cells(i, "A").clear
        End If
    Next i
End Sub

谢谢

Answer 1

这应该适合你：

Sub DeleteDuplicates()
Dim lRow As Long
Dim i, j, k As Integer
Dim Duplicates() As Integer
Dim sht As Worksheet
Dim Val1, Val2 As String

Set sht = Worksheets("Sheet1")

lRow = sht.Cells(Rows.Count, 1).End(xlUp).Row
Index = 0

For i = 7 To lRow
    Val1 = sht.Cells(i, 1).Value
    Index = 0
    For j = i + 1 To lRow
        Val2 = sht.Cells(j, 1).Value
        If Val1 = Val2 Then
            ReDim Preserve Duplicates(Index)
            Duplicates(Index) = j
            Index = Index + 1
        End If
        If j = lRow Then
            If Index > 1 Then
                For k = UBound(Duplicates) - 1 To 0 Step -1
                    sht.Rows(Duplicates(k)).EntireRow.Delete
                Next k
            End If
        End If
    Next j
Next i
End Sub

Answer 2

您需要查看上一行的值和下一行的值。如果上一行的值与当前行的值相同，而下一行的值也是……这是第 3 条以上的记录。

If (Current = Previous) AND (Current = Next) Then
Cells(i, "A").clear
End if

Answer 3

使用字典保存值最后出现的最后一行，以便在再次找到时将其添加到已删除的范围中。诀窍是，如果是第一次出现就不要保存它：在第一次出现时，在字典中输入零而不是行号，这样可以避免删除第一次出现。

Sub keepFirstAndLast()
  Dim toDelete As Range: Set toDelete = Sheet1.Rows(999999) '(to not start with a null range)
  Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")

  Dim a As Range
  For Each a In Sheet1.Range("A7", Sheet1.Range("A999999").End(xlUp))
    If Not dict.Exists(a.Value2) Then
      dict(a.Value2) = 0 ' first appearence, dont save the row
    Else
      ' if last observed occurrence was a duplicate, add it to deleted range
      If dict(a.Value2) > 0 Then Set toDelete = Union(toDelete, Sheet1.Rows(dict(a.Value2)))
      dict(a.Value2) = a.row ' not first appearence, save the row for eventual deletion
    End If
  Next
  toDelete.Delete
End Sub