Loop over rows never ends - vba

Question

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

Answer 1

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