Loop_Find & Copy to word document

[Excelfun]

Hi,
Below code Search string "FORM" on excel worksheet and copy data to word document in table only.
Now i need help to
1. Add loop in below code for find ( Do...Loop)
2. Select row below existing table on word document & copy next table below from excel
i need help to modify below code to find each string "Form" from worksheet & copy data to word document

i will appreciate any help on this

Sub test()
   Dim intNoOfRows
   Dim intNoOfColumns
   Dim objWord
   Dim objDoc
   Dim objRange
   Dim objTable
   Dim WordDoc As Object
'set table row & column
 intNoOfRows = 7
 intNoOfColumns = 2
 'create wrd file
  Set objWord = CreateObject("Word.Application")
  objWord.Visible = True 'add this to see the Word instance and document
  Set objDoc = objWord.Documents.Add
  Dim rng As Range
'Do While True
AppActivate "Microsoft Excel"
Sheet1.Select
'find form on worksheet in column1
Set rng = Columns(1).Find(what:="FORM", LookIn:=xlValues, lookat:=xlPart)
If rng Is Nothing Then Exit Sub
Temp = rng.Row + 1
Temp2 = rng.Row + 7
Temp3 = rng.Row + 5
AppActivate "Microsoft Word"
 objDoc.Range.Select 'select everything in the word document
        With objWord.Selection
        .EndKey 6 'move pointer to the end
        .TypeParagraph 'insert return
        .TypeParagraph 'insert return
        '.Paste 'paste whatever was copied from Excel
    End With
Set objSelection = objWord.Selection
Set objRange = objDoc.Range
objDoc.Tables.Add objRange, intNoOfRows, intNoOfColumns
Set objTable = objDoc.Tables(1)
objTable.Borders.Enable = True
  objTable.Cell(1, 1).Range.Text = Sheet1.Cells(Temp, 1).Value
  objTable.Cell(2, 1).Range.Text = Sheet1.Cells(Temp + 1, 1).Value
  objTable.Cell(3, 1).Range.Text = Sheet1.Cells(Temp + 2, 1).Value
  objTable.Cell(4, 1).Range.Text = Sheet1.Cells(Temp + 3, 1).Value
  objTable.Cell(5, 1).Range.Text = Sheet1.Cells(Temp + 4, 1).Value
  objTable.Cell(6, 1).Range.Text = Sheet1.Cells(Temp + 5, 1).Value
  objTable.Cell(7, 1).Range.Text = Sheet1.Cells(Temp + 6, 1).Value

  objTable.Cell(1, 2).Range.Text = Sheet1.Cells(Temp, 2).Value
  objTable.Cell(2, 2).Range.Text = Sheet1.Cells(Temp + 1, 2).Value
  objTable.Cell(3, 2).Range.Text = Sheet1.Cells(Temp + 2, 2).Value
  objTable.Cell(4, 2).Range.Text = Sheet1.Cells(Temp + 3, 2).Value
  objTable.Cell(5, 2).Range.Text = Sheet1.Cells(Temp + 4, 2).Value
  objTable.Cell(6, 2).Range.Text = Sheet1.Cells(Temp + 5, 2).Value
  objTable.Cell(7, 2).Range.Text = Sheet1.Cells(Temp + 6, 2).Value
  
 objTable.Cell(6, 2).Split NumColumns:=3
  objTable.Cell(6, 3).Range.Text = "AGE"
  objTable.Cell(6, 4).Range.Text = Sheet1.Cells(Temp + 5, 4).Value
 
objDoc.Tables(1).Cell(1, 1).Select
objSelection.SplitTable
objSelection.TypeText Text:="Form 1"
 objDoc.Range.Select 'select everything in the word document
    With objWord.Selection
        .EndKey 6 'move pointer to the end
        .TypeParagraph 'insert return
        .TypeParagraph 'insert return
        '.Paste 'paste whatever was copied from Excel
    End With
AppActivate "Microsoft Word"
AppActivate "Microsoft Excel"

    Set objDoc = Nothing 'release memory
    Set objWord = Nothing 'release memory
End Sub