Loop_Find & Copy to word document

**Excelfun** · 01-14-2014, 12:00 AM

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

**Admin** · 01-14-2014, 12:19 PM

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

**snb** · 01-14-2014, 02:59 PM

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