Loop_Find & Copy to word document

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

Code:

---

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

---

Hi

I think this should work.

Code:

---

Sub test()
 
  Dim lngNoOfRows          As Long
  Dim lngNoOfColumns      As Long
  Dim objWord              As Object
  Dim objDoc              As Object
  Dim objRange            As Object
  Dim objTable            As Object
 
'  Dim objWord              As Word.Application
'  Dim objDoc              As Word.Document
'  Dim objRange            As Word.Range
'  Dim objTable            As Word.Table
 
  Dim fa                  As String
  Dim rngSearch            As Range
  Dim rng                  As Range
 
    'set table row & column
    lngNoOfRows = 7
    lngNoOfColumns = 2
   
    Set rngSearch = Sheet1.UsedRange.Columns(1)
   
    '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
   
    'AppActivate "Microsoft Excel"
   
    'find form on worksheet in column1
    Set rng = rngSearch.Find(what:="FORM", LookIn:=xlValues, lookat:=xlPart)
   
    If rng Is Nothing Then Exit Sub
    fa = rng.Address
   
    Do
   
        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 objTable = Nothing
        Set objRange = objDoc.Content
            objRange.Collapse Direction:=wdCollapseEnd

        Set objTable = objDoc.Tables.Add(objRange, lngNoOfRows, lngNoOfColumns)
        'Set objTable = objDoc.Tables(1)
        objTable.Borders.Enable = True
        objTable.Cell(1, 1).Range.Text = rngSearch.Parent.Cells(Temp, 1).Value
        objTable.Cell(2, 1).Range.Text = rngSearch.Parent.Cells(Temp + 1, 1).Value
        objTable.Cell(3, 1).Range.Text = rngSearch.Parent.Cells(Temp + 2, 1).Value
        objTable.Cell(4, 1).Range.Text = rngSearch.Parent.Cells(Temp + 3, 1).Value
        objTable.Cell(5, 1).Range.Text = rngSearch.Parent.Cells(Temp + 4, 1).Value
        objTable.Cell(6, 1).Range.Text = rngSearch.Parent.Cells(Temp + 5, 1).Value
        objTable.Cell(7, 1).Range.Text = rngSearch.Parent.Cells(Temp + 6, 1).Value
       
        objTable.Cell(1, 2).Range.Text = rngSearch.Parent.Cells(Temp, 2).Value
        objTable.Cell(2, 2).Range.Text = rngSearch.Parent.Cells(Temp + 1, 2).Value
        objTable.Cell(3, 2).Range.Text = rngSearch.Parent.Cells(Temp + 2, 2).Value
        objTable.Cell(4, 2).Range.Text = rngSearch.Parent.Cells(Temp + 3, 2).Value
        objTable.Cell(5, 2).Range.Text = rngSearch.Parent.Cells(Temp + 4, 2).Value
        objTable.Cell(6, 2).Range.Text = rngSearch.Parent.Cells(Temp + 5, 2).Value
        objTable.Cell(7, 2).Range.Text = rngSearch.Parent.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 = rngSearch.Parent.Cells(Temp + 5, 4).Value
       
        objTable.Cell(1, 1).Select
        Set objSelection = objWord.Selection
        objSelection.SplitTable
        objSelection.TypeText Text:=rng.Value2
   
        Set rng = rngSearch.FindNext(rng)
    Loop While Not rng Is Nothing And rng.Address <> fa
   
    AppActivate "Microsoft Excel"

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

---

Or you might use VBA:

Code:

---

Sub M_snb()
  With CreateObject("Word.Document")
        For j = 1 To sheets("Sheet1").Columns(1).SpecialCells(2).Count Step 8
          sheets("Sheet1").Cells(j, 1).Resize(8, 4).Copy
          .Paragraphs.last.Range.Paste
          .Content.InsertAfter String(3, vbCr)
        Next
  End With
End Sub

---

Thank u so much Admin & snb for your time & help..!