Do While Nested Loops

This is a messy code, but it works if I'm not mistaken to get what you mean :

Sub test()
'Range("D:D").ClearContents
lr = Columns(1).Rows.Count
Set Rng1 = Range("A:A")
Set oTarget = Sheets("Sample2").Range("D" & lr) 'change as your need (in your workbook is Sheet Output column A)

Set c = Rng1.Find("StartHeader", LookAt:=xlPart, After:=Range("A" & lr))
If Not c Is Nothing Then
FirstAddress = c.Address
        Do
        Set oFill = oTarget.End(xlUp).Offset(1, 0)
        Set oPage = oFill
        Range(c, c.Offset(5, 0)).Copy Destination:=oFill
        Set check1 = c.Offset(6, 0)
        Set x = check1
            Do
            FirstCheck = x.Value
            Set check2 = x
            Set x = x.Offset(1, 0)
                    If x.Value <> FirstCheck Then
                    Set oFill = oTarget.End(xlUp).Offset(1, 0)
                    oFill.Value = "Page " & FirstCheck
                    Range(check1, check2).Copy Destination:=oFill.Offset(1, 0)
                    Set check1 = x
                    End If
                    
                    If x.Value = "" Then
                    Set rngPage = Range(oPage, oFill)
                        For Each cell In rngPage
                        If InStr(cell, "Page") Then _
                        cell.Value = cell.Value & " of " & FirstCheck
                        Next
                        GoTo finish
                        End If
            Loop Until InStr(x, "StartHeader")
             
            Set rngPage = Range(oPage, oFill)
            For Each cell In rngPage
            If InStr(cell, "Page") Then _
            cell.Value = cell.Value & " of " & FirstCheck
            Next

        Set c = Rng1.FindNext(c)
        Loop While c.Address <> FirstAddress
End If

finish:
Sheets("Sample2").Range("D1").Delete Shift:=xlUp 'change as needed
'Range("A:C").EntireColumn.Delete --->unmark this if you want the output is in the same sheet.
End Sub

Oopss... sorry, I didn't realize that what you want is to insert entire row .

Here is the code which do the insert.

Sub test2()
lr = Columns(1).Rows.Count
Set Rng1 = Range("A:A")

Set c = Rng1.Find("StartHeader", LookAt:=xlPart, After:=Range("A" & lr))
If Not c Is Nothing Then
FirstAddress = c.Address
Do
Set check1 = c.Offset(6, 0)
c.Offset(6, 0).EntireRow.Insert
n = n + 1
c.End(xlDown).Offset(1, 0).Value = "Page" & n
Set check = check1.Offset(1, 0)

Do
If check.Value <> check1.Value Then
If check.Value = "StartHeader" Then Exit Do
If check.Value = "" Then
Set Rng = Range(c, check)
For Each cell In Rng
If InStr(cell, "Page") Then cell.Value = cell.Value & " of " & n
Next
Exit Sub
End If
n = n + 1
check.EntireRow.Insert
Set RngPage = c.End(xlDown).Offset(1, 0)
c.End(xlDown).Offset(1, 0).Value = "Page" & n
End If
Set check1 = check
Set check = check1.Offset(1, 0)
Loop

Set Rng = Range(c, check)
For Each cell In Rng
If InStr(cell, "Page") Then cell.Value = cell.Value & " of " & n
Next
n = 0
Set c = Rng1.FindNext(c)
Loop While c.Address <> FirstAddress
End If
End Sub

This code is assuming that each "number" has the same value. For example :
the number "1" in your example (under page 1 of n) value is 1_aaa, the next row is also 1_aaa
So if the number "1" value is : 1_aaa, 1_aab, and so on, the code will fail
because the code doesn't check the number but the value.

StartHeader		
1		
R		
R		
R		
N	FAIL	 WORK
1	1aaa	 1aaa
1	1aab	 1aaa
1	1aac	 1aaa
1	1aad	 1aaa
2	2xx1	 2xx1
2	2xx2	 2xx1
2	2xx3	 2xx1
2	2xx4	 2xx1