Move Entire Row To Different Worksheet Based On Exact Cell Value

[st3v3y]

Hi there

I apologise if this has been solved but I have searched and can't find the answer. I have 'stitched' bits of code together and feel so close to solving this. I have this working but it won't 'loop' and therefore only completes the task for individual rows.

In a nutshell I search Sheet 1, Column Q, Row 3 onwards for a set value and then move the entire row to Sheet 3, Row 3 onwards. My code works but I have to run it 10 times if there are 10 rows that contain the value of 1 in them.

As you can probably tell, I'm useless at VBA!

Here is my code....

Sub MoveRows()

Dim cell As Range
Dim lastrow As Long, i As Long

lastrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row

i = 3

For Each cell In Sheets(1).Range("Q3:Q" & lastrow)

    If cell.Value = 1 Then
        cell.EntireRow.Copy Sheets(4).Range("A" & Rows.Count).End(xlUp).Offset(1)
        cell.EntireRow.Delete
        i = i + 1
    End If
        
Next

End Sub

If I want to search for a value of 2 and move to sheet 5 then I have to change theses value and keep running again.

I would like to add this to my code but don't know how to?

For Each cell In Sheets(1).Range("Q3:Q" & lastrow)
If cell.Value = 2 Then
        cell.EntireRow.Copy Sheets(5).Range("A" & Rows.Count).End(xlUp).Offset(1)
        cell.EntireRow.Delete
        i = i + 1
    End If

I can add a sample sheet if required but basically I'm just trying to look at everything in column Q from row 3 onwards so wasn't sure if it was needed as the rest of the row data is irrelevant.

Thanks for reading this.
Steve