VBA help with copy pasting rows

[vbahelpneeded15]

Hi,
I have been trying to set up a VBA code that helps me move rows with the word Sam in column A to the bottom of the sheet (the number of rows with this word changes everyday). I have managed to set up a code that copies the data but it always pastes it in the same row (i.e. row 540) even if it is not the next empty row. I was wondering if I could get some help with it so it pastes in the next empty row instead.
Here's my code:

Sub Step3 ()
Dim r As Range
Dim s As String
Dim firstRowWithS As Long, lastRowWithS As Long, destinationRow As Long

s = "Sam"
destinationRow = 540

For Each r In Sheets("sheetname").Range("A373:A398")
'find first row where we see string s
If r.value = s And r.Offset(-1, 0).value <> s Then
firstRowWithS = r.Row
End If

'find last row where we see string s
If r.value <> s And r.Offset(-1, 0).value = s Then
lastRowWithS = r.Offset(-1, 0).Row
End If
Next

'copy and paste rows to destination
Sheets("sheetname").Range(373 & ":" & 398).Copy Destination:=Sheets("sheetname").Range("A" & destinationRow)
End Sub

Thank you for the help!

 

[vbahelpneeded15]

Would the presence of the word "Sam" not be enough?

 

[Joe4]

Would the presence of the word "Sam" not be enough?

So, are you saying that you want to search every single row in column A that has an entry, starting at row 1?
If so, maybe something like this:

Sub Step3()

    Dim r As Range
    Dim s As String
    Dim firstRowWithS As Long, lastRowWithS As Long, lastRow As Long, destinationRow As Long

    s = "Sam"
    
    lastRow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
    destinationRow = lastRow + 1
    
    For Each r In Sheets("Sheet1").Range("A2:A" & lastRow)
        'find first row where we see string s
        If r.Value = s And r.Offset(-1, 0).Value <> s Then
            firstRowWithS = r.Row
        End If
        'find last row where we see string s
        If r.Value <> s And r.Offset(-1, 0).Value = s Then
            lastRowWithS = r.Offset(-1, 0).Row
        End If
    Next

    'cut and paste rows to destination
    Sheets("Sheet1").Range(Cells(firstRowWithS, "A"), Cells(lastRowWithS, "A")).Cut Destination:=Sheets("Sheet1").Range("A" & destinationRow)
    
End Sub

Note that I am actually starting on row 2, and not row 1, since you have some code that looks at the row above it that would blow up if we started on row 1.

 

[vbahelpneeded15]

Hi,
This row shows an application defined or object defined error
Sheets("Sheet1").Range(Cells(firstRowWithS, "A"), Cells(lastRowWithS, "A")).Cut Destination:=Sheets("Sheet1").Range("A" & destinationRow)

 

[Joe4]

Check the value of each of the variables use in the equation at run-time and see if they all make makes sense.