除去列有重复的数据在Excel

Question

我有这个代码的问题：

Sub text() 

Dim iListCount As Integer 
Dim x As Variant 
Dim iCtr As Integer 

' Turn off screen updating to speed up macro. 
Application.ScreenUpdating = False 

' Get count of records to search through (list that will be deleted). 
iListCount = Sheets("sheet2").Cells(Rows.Count, "C").End(xlUp).Row 

' Loop through the "master" list. 
For Each x In Sheets("Sheet2").Range("A1:A" & Sheets("Sheet2").Cells(Rows.Count, "C").End(xlUp).Row) 
     ' Loop through all records in the second list. 
     For iCtr = iListCount To 1 Step -1 
     ' Do comparison of next record. 
     ' To specify a different column, change 1 to the column number. 
     If x.Value = Sheets("Sheet2").Cells(iCtr, 3).Value Then 
     ' If match is true then delete row. 
      Sheets("Sheet2").Cells(iCtr, 1).EntireRow.Delete 
      End If 
     Next iCtr 
Next 
Application.ScreenUpdating = True 
MsgBox "Done!" 
End Sub 

它运行，而这类作品的。它删除一个重复，但留下所有其他重复。我正在测试这个，所以我使用了一个小样本大小，所以我知道有5个重复项，但是我无法得到这个代码来将它们全部删除。有任何想法吗？我认为它的问题与循环，但不管我改变，我不能让它的工作

Answer 1

通过在内环删除整个行要修改，该外环在中间圈穿过的范围内循环。这样的代码很难调试。

你的嵌套循环结构本质上是一系列的线性搜索。这会使整个行为在行数上呈现二次方，并且会使应用程序变慢。一种方法是使用可在VBA中使用的dictionary，如果您的项目包含对Microsoft Scripting Runtime（工具 - VBA编辑器中的参考）的引用

以下子代使用字典删除列C中具有发生在列中的值：

Sub text() 
    Dim MasterList As New Dictionary 
    Dim iListCount As Integer 
    Dim x As Variant 
    Dim iCtr As Integer 
    Dim v As Variant 

    Application.ScreenUpdating = False 

    ' Get count of records in master list 
    iListCount = Sheets("sheet2").Cells(Rows.Count, "A").End(xlUp).Row 
    'Load Dictionary: 
    For iCtr = 1 To iListCount 
     v = Sheets("sheet2").Cells(iCtr, "A").Value 
     If Not MasterList.Exists(v) Then MasterList.Add v, "" 
    Next iCtr 

    'Get count of records in list to be deleted 
    iListCount = Sheets("sheet2").Cells(Rows.Count, "C").End(xlUp).Row 

    ' Loop through the "delete" list. 
     For iCtr = iListCount To 1 Step -1 
      If MasterList.Exists(Sheets("Sheet2").Cells(iCtr, "C").Value) Then 
       Sheets("Sheet2").Cells(iCtr, "C").Delete shift:=xlUp 
      End If 
     Next iCtr 
    Application.ScreenUpdating = True 
    MsgBox "Done!" 
End Sub 

Answer 2

另一种选择是，以循环通过细胞，使用Find和FindNext找到重复，并将它们添加到使用Union()的范围内。然后您可以在例程结束时删除该范围。这解决了在遍历它们时删除行的问题，并且应该执行得非常快。

注：此代码是未经测试，可能需要调试。

Sub text() 

    Dim cell As Range 
    Dim lastCell as Range 
    Dim masterList as Range 
    Dim matchCell as Range 
    Dim removeUnion as Range 
    Dim firstMatch as String 

    ' Turn off screen updating to speed up macro. 
    Application.ScreenUpdating = False 

    With Sheets("sheet2").Range("A:A") 
    ' Find the last cell with data in column A 
     Set lastCell = .Find("*", .Cells(1,1), xlFormulas, xlPart, xlByRows, xlPrevious) 
    ' Set the master list range to the used cells within column A 
     Set masterList = .Range(.cells(1,1) , lastCell) 
    End With 

    ' Loop through the "master" list. 
    For Each cell In masterList 
    ' Look for a match anywhere within column "C" 
     With cell.Parent.Range("C:C") 
      Set matchCell = .Find(.Cells(1,1), cell.Value, xlValues, xlWhole, xlByRows) 

      'If we got a match, add it to the range to be deleted later and look for more matches 
      If Not matchCell is Nothing then 

       'Store the address of first match so we know when we are done looping 
       firstMatch = matchCell.Address 

       'Look for all duplicates, add them to a range to be deleted at the end 
       Do 
        If removeUnion is Nothing Then 
         Set removeUnion = MatchCell 
        Else 
         Set removeUnion = Application.Union(removeUnion, MatchCell) 
        End If 
        Set MatchCell = .FindNext 
       Loop While (Not matchCell Is Nothing) and matchCell.Address <> firstMatch 
       End If 
       'Reset the variables used in find before next loop 
       firstMatch = "" 
       Set matchCell = Nothing 

     End With 

    Next 

    If Not removeUnion is Nothing then removeUnion.EntireRow.Delete 

    Application.ScreenUpdating = True 
    MsgBox "Done!" 
End Sub