Removing duplicate data from columns in Excel - vba

Question

I am having an issue with this code:
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
It runs, and kind of works. It removes one duplicate but leaves all of the others. I am testing this so I'm using a small sample size, so I know that there are 5 duplicates, however I can't get this code to remove them all. Any ideas? I think its an issue with the loop but no matter what I change I can't get it to work

Answer 1

By deleting entire rows in the inner loop you are modifying the range that the outer loop is looping through in the middle of the loop. Such code is difficult to debug.
Your nested loop structure is essentially a series of linear searches. This makes the overall behavior quadratic in the number of rows and can slow the application to a crawl. One approach is to use a dictionary which can be used in VBA if your project includes a reference to Microsoft Scripting Runtime (Tools - References in the VBA editor)
The following sub uses a dictionary to delete all cells in column C which have a value that occurs in column A:
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

Another option would be to loop through the cells, use Find and FindNext to find the duplicates and add them to a range using Union(). You could then delete that range at the end of the routine. This solves the problem with deleting rows as you iterate over them, and should execute pretty quickly.
Note: This code is untested, you may need to debug it.
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