Stuck in loop while code has been properly executed

user_12147425 0
Viewed 58

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
vba excel loops
3 Answers

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
user_91733790

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

user_73829140

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.

user_91998280
Related