Question

所以我有一个包含大量数据的列（大约8,000个单元格），我想添加新的单元格。其中一些单元格是重复的，我想删除它们。但是，在这8,000个原始单元中已经有一些重复，无法移除。所以RemoveDuplicates无法工作。我想要做的就是快速获得它，所以不是通过每个单元格的For，这将是我的第二选择。

这就是我一直在尝试做的事情（这是一个很重要的代码，但这是重要的部分）：

With ActiveSheet
    With .Range("D5", .Range("D5").End(xlDown)
      .ClearFormats 'this part I copied from macro recording basically
      .FormatConditions.AddUniqueValues
      .FormatConditions(.FormatConditions.Count).SetFirstPriority
      .FormatConditions(1).DupeUnique = xlDuplicate
        With .FormatConditions(1).Interior
            .PatternColorIndex = xlAutomatic
            .Color = 13551615
        End With
      .FormatConditions(1).StopIfTrue = False
      .Range("D5", .Range("D5").End(xlDown)).Calculate
      'Calculation is manual, so I'm putting this in case it's not doing the formatting now
      End With
    For Each Cell In .Range("D" & First_Row_of_new_data, .Range("D5").End(xlDown))
    'I'm trying to delete all cells which have changed colors, meaning they're duplicates
        If Cell.Interior.ColorIndex = 13551615 Then
            Cell.EntireRow.Delete
        End If
    Next Cell
End With

这里的问题是最后一部分没有做任何事情。所有变量都已在之前正确定义。

任何帮助将不胜感激！

Answer 1

执行您需要做的事情的最简单方法可能是使用Dictionary结构。例如，您只需将您在某个范围内遇到的每个值添加到字典中，如果存在，则考虑将其标记为删除。在下面的情况中，您应该删除旁边有<的单元格：

Option Explicit

Public Sub TestMe()

    Dim myRange As Range
    Dim myCell  As Range
    Dim myDict  As Object

    Set myDict = CreateObject("Scripting.Dictionary")
    Set myRange = Range("A1:A11")

    For Each myCell In myRange
        Debug.Print myCell
        If myDict.exists(CStr(myCell)) Then
            myCell.Interior.Color = vbRed
        Else
            myDict.Add CStr(myCell), 1
        End If
    Next myCell

End Sub

因此，在执行第一个代码后，您将获得右侧的图片。为了删除红色的单元格，你应该从11循环到1：

Public Sub TestMe()

    Dim myRange As Range
    Dim cnt     As Long

    Set myRange = Range("A1:A11")

    For cnt = myRange.Rows.Count To 1 Step -1
        If Cells(cnt, 1).Interior.Color = vbRed Then
            Cells(cnt, 1).Delete
        End If
    Next cnt

End Sub

为了进一步升级代码，如果第一行不是数字1并且myRange没有硬编码，请考虑使其有效。

Answer 2

我被击败了帖子，但是自从我编码之后我就加入了我的帖子。显然，做出必要的改变。我还考虑直接删除该行，而不是将其着色，然后在事后删除它。

Sub DeleteNewDuplicates()
    Dim rngOriginal As Range
    Dim rngNewData As Range
    Dim oDict As Object
    Dim rIterator As Range
    Dim nLastRowNewData As Long
    Dim t As Single

    Application.ScreenUpdating = False

    t = Timer

    'Assume the original data is range A1:A25, and it may contain duplications
    Set rngOriginal = Sheet1.Range("A1:A8000")

    'New Data is added from A26 to A100
    Set rngNewData = Sheet1.Range("A8001:A120075")

    'Create a dictionary to hold the unique values in the original range
    Set oDict = CreateObject("Scripting.Dictionary")

    'Add unique values to the dictionary
    For Each rIterator In rngOriginal
        'If not already in the dictionary, add it, otherwise ignore
        If Not oDict.exists(rIterator.Value) Then
            oDict.Add rIterator.Value, ""
        End If
    Next rIterator

    'Need to loop throw the new range in reverse so as to not skip rows
    nLastRowNewData = rngNewData.Range("A1").Offset(rngNewData.Rows.Count).Row - 1

    For i = nLastRowNewData To rngNewData.Range("A1").Row Step -1
        'If it is in the dictionary, then it is a duplicate and we can delete
        If oDict.exists(Sheet1.Range("A" & i).Value) Then
            Sheet1.Rows(i).Delete
        Else
            'Otherwise add it to the dictionary so it doesn't get repeated
            oDict.Add Sheet1.Range("A" & i).Value, ""
        End If
    Next i

    Application.ScreenUpdating = True

    Debug.Print "Process took approximately ... " & Timer - t & " seconds."

End Sub

删除新的重复项但不删除旧重复项

2 个答案: