I have written the following code to clear the dataset of duplicates if it meets a certain criteria (column E). It scans through 1216 lines of data (LastRow has 1216 hits) and clears the duplicates. Only issue I had was if I had two or three duplicates it would only delete one duplicate.
I wrote another line of code stating if a single item (column B) is found more than once that a variable called statement is equal to TRUE. So I want the loop to continue until no duplicates are present in the dataset, which will also turn the variable to FALSE and stop the loop. However, the loop continues endlessly. When I stop the script manually it seems to have cleared all the duplicates.
Sub ClearDataSet()
Dim LastRow As Integer
Dim i As Integer
Dim Rng, cell As Range
Dim Statement As Boolean
Set ws1 = ThisWorkbook.Worksheets("sheet1")
Set Rng = ws1.Range(("D1"), ws1.Range("D1").End(xlDown))
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
ws1.Range("A1").CurrentRegion.Sort _
key1:=ws1.Range("D1"), order1:=xlAscending, _
Key2:=ws1.Range("E1"), order2:=xlAscending, Header:=xlYes
Do
For i = 2 To LastRow
If ws1.Cells(i, "D") = ws1.Cells(i + 1, "D") And _
(ws1.Cells(i, "E") < ws1.Cells(i + 1, "E") Or _
ws1.Cells(i, "E") = ws1.Cells(i + 1, "E")) Then
Rows(i).Delete
End If
Next i
For Each cell In Rng
If WorksheetFunction.CountIf(Rng, cell.Value) > 1 Then
Statement = True
End If
Next cell
Loop Until Statement <> True
End Sub
EDIT: Tweaked (and more efficient) script after solution of M Schalk
Sub ClearDataSet()
Dim LastRow As Integer
Dim i As Integer
Dim Rng, cell As Range
Dim Statement As Boolean
Dim StartTime As Long
Dim TimeElapsed As Long
StartTime = Timer
Set ws1 = ThisWorkbook.Worksheets("sheet1")
Set Rng = ws1.Range(("D1"), ws1.Range("D1").End(xlDown))
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
ws1.Range("A1").CurrentRegion.Sort _
key1:=ws1.Range("D1"), order1:=xlAscending, _
Key2:=ws1.Range("E1"), order2:=xlAscending, Header:=xlYes
For i = 2 To LastRow
If ws1.Cells(i, "D").Value = "" Then
GoTo OverStepcode
ElseIf _
ws1.Cells(i, "D") = ws1.Cells(i + 1, "D") And _
(ws1.Cells(i, "E") < ws1.Cells(i + 1, "E") Or _
ws1.Cells(i, "E") = ws1.Cells(i + 1, "E")) Then
Rows(i).Delete
i = i - 1
End If
Next i
OverStepcode:
TimeElapsed = Round(Timer - StartTime)
MsgBox "The code ran successfully in " & TimeElapsed & " seconds vbinformation"
End Sub
Nowhere inside the loop do you set statement
to False
. Therefore the loop end condition will never be fulfilled. If I understand your goal correctly you should add it here:
If ws1.Cells(i, "D") = ws1.Cells(i + 1, "D") And _
(ws1.Cells(i, "E") < ws1.Cells(i + 1, "E") Or ws1.Cells(i, "E") = ws1.Cells(i + 1, "E")) Then
Rows(i).Delete
statement = False
End If
Also, Loop Until Statement <> True
is the same as Loop Until Statement = False
, which I find a bit easier to read.
On a separate note, this seems like an overly complicated approach, have you tried using Remove Duplicates
?
As another more lightweight solution you could remove the whole statement
thing and simply add i = i - 1
after finding a duplicate. This makes sure that you catch multiple duplicates of the same value and you don't need the whole Do... Loop
part. Try this modified version.
For i = 2 To LastRow
If ws1.Cells(i, "D") = ws1.Cells(i + 1, "D") And _
(ws1.Cells(i, "E") < ws1.Cells(i + 1, "E") Or ws1.Cells(i, "E") = ws1.Cells(i + 1, "E")) Then
Rows(i).Delete
i = i - 1
End If
Next i
The problem might be there:
For Each cell In Rng
If WorksheetFunction.CountIf(Rng, cell.Value) > 1 Then
Statement = True
End If
Next cell
Statement
gets set to true
, if there are duplicates left. it needs to check, if there are none left and then set it to false
I see two things:
First: you do a Do Until Statement<>True
. But in your code, there is nothing that changes the value of Statement
. At first run of code, when VBA initializes de variable for the first time, yes, default value will be False
, but then your code changes the value here:
If WorksheetFunction.CountIf(Rng, cell.Value) > 1 Then
Statement = True
End IF
So the condition is probably not being fulfilled.
ADVICE: When you use an If...then
, you can type everything in 1 single line if there is only one statement and there is no Else
part. This means your code above could be resumed like this:
If WorksheetFunction.CountIf(Rng, cell.Value) > 1 Then Statement = True
Second: This is just theory, I've not tested properly.
Your For Each
, I think it may not working properly. You have this:
For Each cell In Rng
If WorksheetFunction.CountIf(Rng, cell.Value) > 1 Then
Statement = True
End If
Next cell
In code above, you are looping torugh each cell in rng.
And before, you did Set Rng = ws1.Range(("D1"), ws1.Range("D1").End(xlDown))
. But later on you delete rows, and you never updated rng
. This means that, probably, there are several blank values in rng
, because you assigned the range before deleting.
Because there are several blank values, WorksheetFunction.CountIf(Rng, cell.Value)
will return always more than 1, making Statement=True
and creating an eternal loop.
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.