Удаление дубликатов данных из столбцов в 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

Удаляя целые строки во внутреннем цикле, вы изменяете диапазон, в котором внешний цикл проходит через середину петля. Такой код трудно отлаживать.

Ваша структура вложенной петли представляет собой, по существу, ряд линейных поисков. Это делает общее поведение квадратичным по количеству строк и может замедлить приложение при обходе. Один из подходов состоит в использовании dictionary, который может использоваться в VBA, если ваш проект содержит ссылку на 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