Loop over rows never ends

January 20, 2022

I have a list of around 20k rows and several columns. One of these columns contains comments. The code below iterates through the rows of the list, copies all the rows that have the comment "Date of Payment", and pastes them into another sheet.

But the loop never ends.

What is the problem?

Here is my code:

Sheets("MASTER").Select

rowslength = Range("O" & Rows.Count).End(xlUp).Row
'MsgBox rowslength

Set keyword1 = Cells.Find(what:="Date of Payment")
For i = 1 To rowslength
    keyword1.Select
    Selection.EntireRow.Select
    Selection.Copy
    With Sheets("Date of Payment").Range("a" & Rows.Count).End(xlUp).Offset(1)
    .PasteSpecial
    End With
    Sheets("MASTER").Select
    Set keyword1 = Cells.FindNext(keyword1)
    Application.CutCopyMode = False

Next i

>Solution :

As Warcupine said in the comments, you are looping from the first row to the last row in your populated range. Lets say this is 20,000 rows. But perhaps you only have 500 comments that match your criteria. Even though you copied all the data you need, the for loop will continue to process another 19,500 iterations. All you need to do is store the first occurrence before you enter the for-loop and then on each interation, check if the next found cell matches the first found cell. Like this:

Sub test()
    Sheets("MASTER").Select
    
    rowslength = Range("O" & Rows.Count).End(xlUp).Row
    'MsgBox rowslength
    
    Set keyword1 = Cells.Find(what:="Date of Payment")
    Set firstFoundCell = keyword1 'store the first found cell
    
    For i = 1 To rowslength
        keyword1.Select
        Selection.EntireRow.Select
        Selection.Copy
        With Sheets("Date of Payment").Range("a" & Rows.Count).End(xlUp).Offset(1)
            .PasteSpecial
        End With
        Sheets("MASTER").Select
        Set keyword1 = Cells.FindNext(keyword1)
        Application.CutCopyMode = False
        
        If keyword1.Address = firstFoundCell.Address Then Exit For 'stop when back at the first cell
    
    Next i
End Sub