rkulasekaran
06-14-2015, 11:23 PM
Hi all,
I am able to extract the contents from word to excel through the below code, the active document(Word) is opened and the code is executed from an excel application VBA, I just want to convert it and open from word VBA, I have attached the sample word document also, please any one can help me out .
Sub InsertRow()
Dim WordApp As Object
Dim oDoc As Object
Dim oRng As Object, oEndRng As Object
Dim NextRow As Long
On Error GoTo ReturnError
' Check if Word is already open
Set WordApp = GetObject(, "Word.Application")
Set oDoc = WordApp.activedocument
Set oRng = oDoc.Range
'Find the next empty row of the worksheet
NextRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
With oRng.Find
'Find the text string
Do While .Execute(FindText:="CA-PTS-ADIRU")
'Find the next occurrence of 'Rationale'
Do Until oRng.Words.Last = "Rationale"
'Move the end of the range one word at a time
oRng.MoveEnd 2, 1
Loop
oRng.MoveEnd 2, -1
oRng.End = oRng.End - 1
oRng.MoveStartUntil Chr(9)
oRng.Start = oRng.Start + 1
'And put the text in Column 1 (A)
Cells(NextRow, 1) = oRng.Text
'Format the cell
With Cells(NextRow, 1)
.ColumnWidth = "48"
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'Collapse the range to its end
oRng.Collapse 0
'Increment the row
NextRow = NextRow + 1
Loop
End With
Exit Sub
ReturnError:
MsgBox "Word is not running!"
End Sub
I am able to extract the contents from word to excel through the below code, the active document(Word) is opened and the code is executed from an excel application VBA, I just want to convert it and open from word VBA, I have attached the sample word document also, please any one can help me out .
Sub InsertRow()
Dim WordApp As Object
Dim oDoc As Object
Dim oRng As Object, oEndRng As Object
Dim NextRow As Long
On Error GoTo ReturnError
' Check if Word is already open
Set WordApp = GetObject(, "Word.Application")
Set oDoc = WordApp.activedocument
Set oRng = oDoc.Range
'Find the next empty row of the worksheet
NextRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
With oRng.Find
'Find the text string
Do While .Execute(FindText:="CA-PTS-ADIRU")
'Find the next occurrence of 'Rationale'
Do Until oRng.Words.Last = "Rationale"
'Move the end of the range one word at a time
oRng.MoveEnd 2, 1
Loop
oRng.MoveEnd 2, -1
oRng.End = oRng.End - 1
oRng.MoveStartUntil Chr(9)
oRng.Start = oRng.Start + 1
'And put the text in Column 1 (A)
Cells(NextRow, 1) = oRng.Text
'Format the cell
With Cells(NextRow, 1)
.ColumnWidth = "48"
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'Collapse the range to its end
oRng.Collapse 0
'Increment the row
NextRow = NextRow + 1
Loop
End With
Exit Sub
ReturnError:
MsgBox "Word is not running!"
End Sub