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

[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

[snb]

Or you might use VBA:


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

[Excelfun]

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