Loop to copy rows and paste into worksheet

[damiencarr]

i have a spreadsheet/worksheet called "NTH_Allian ce" containing rows of related data grouped together under different headings, that are named as different weeks (e.g. Week 5 (26/01/2009 - 1/02/2009), or Week 6 (2/02/2009 - 8/02/2009)).
im writing a macro where the user enters a specific week they wish to see data for (e.g. Week 5 (26/01/2009 - 1/02/2009)), and once the week is found (which can be on any row in the spreadsheet - i.e. not fixed to a specific row number), copy that row and its related rows of data underneath it (which is a dynamic number of rows - it isn't fixed to a specific number of rows), and paste them onto a new worksheet called "Jobs Per Week".
so obviously some kind of loop is required, but im not sure what.
what separates the weeks (i.e. the groups of data) on the worksheet "NTH_Allian ce" is a value in column A called "NTH" (short for "NORTH SECTION", which can be on any row in the spreadsheet - i.e. not fixed to a specific row number).
so in the loop, once the next "NTH" value in column A is reached, i need the loop to stop, and copy all of the rows above it - i.e. the rows from "Week 5 (26/01/2009 - 1/02/2009)" all the way down to the row before the next "NTH".

the code i have so far which works is:

Sub test()
    
'find Week search term in worksheet
    Dim FindString As String
    Dim Rng As Range
    FindString = InputBox("Enter your Search value:  Week 5 (26/01/2009 - 1/02/2009)")
    If Trim(FindString) <> "" Then
        With Sheets("NTH_Alliance").Range("A:Z")
            Set Rng = .Find(What:=FindString, _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
            If Not Rng Is Nothing Then
                Application.Goto Rng, True
            Else
                MsgBox "Nothing found"
            End If
        End With
    End If
    
'copy current row
    Dim FoundRow As Integer
    FoundRow = ActiveWindow.RangeSelection.Row
    Rows(FoundRow).Select
    Selection.Copy
    Sheets("Jobs Per Week").Select
    ActiveSheet.Paste Destination:=Worksheets("Jobs Per Week").Cells(1, 1)

End Sub

i now need a Loop to copy the relevant rows and paste them into worksheet "Jobs Per Week".