Loop_Find & Copy to word document

[Admin]

Hi

I think this should work.

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