Unable to extract the field values in Word

[rkulasekaran]

hi,

I am trying to extract few contents fro word to excel, which contains plain text as well as field datas, i have tried to extract the field information, but unable to extract the corresponding values to field and also the text in the word,

the word document contains like this,


CA-PTS-ADIRU-AG023-1 The ADR shall be capable to store and manage several sets of correction coefficients. The selection of these sets is based on the aircraft type ("Aircraft identification code" input discretes) and on the position of the ADIRU (SDI = 1, 2, 3).


Rationale: TBD
Assumptions: TBD
Additional info.: TBD
Author: A. GUILLET
Creation date (dd/mm/yyyy): 22/10/2001
Stakeholder: TBD
Source: TBD
Link to: CA-SRD-ADIRU-SNS-CSM060-1
Level: TBD


The first two lines contains text

ex:Rationale, Assumptions, Additional info,......are field and the corresponding values are text



Dim fieldLoop As Field

For Each fieldLoop In ActiveDocument.Fields
MsgBox Chr(34) & fieldLoop.Code.Text & Chr(34)
Next fieldLoop

[gmayor]

If the data is stored in fields, then take a look at http://www.gmayor.com/ExtractDataFromForms.htm

[rkulasekaran]

hi Thanks for your reply. the fields that i have mentioned above is not form fields, when i Edit the field, ti get the field property as a quote
And i am able to display "Rationale" "Assumptions" by the above snippet i have posted and not able to get the corresponding values i.e. TBD as shown in the above example

[gmayor]

Rather than us guessing at answers can you 'Go Advanced' and post a sample document as an attachment to the forum, so we can see what it is that you have to work with?

[rkulasekaran]

hi,
I have attached a sample file please do check it out

[gmayor]

If the documents are all similar then the following will work. Replace the various message boxes with whatever you want for those values.



Option Explicit
Sub ExtractText()
Dim ofld As field
Dim oPara As Range
Set oPara = ActiveDocument.Paragraphs(1).Range
oPara.End = oPara.End - 1
oPara.MoveStartUntil Chr(9)
oPara.Start = oPara.Start + 1
MsgBox oPara.Text
For Each ofld In ActiveDocument.Fields
If ofld.Type = wdFieldQuote Then
Select Case True
Case InStr(1, ofld.Code, "Rationale:")
MsgBox GetValue(ofld)
Case InStr(1, ofld.Code, "Assumptions:")
MsgBox GetValue(ofld)
Case InStr(1, ofld.Code, "Additional info:")
MsgBox GetValue(ofld)
Case InStr(1, ofld.Code, "Author:")
MsgBox GetValue(ofld)
Case InStr(1, ofld.Code, "Creation date")
MsgBox GetValue(ofld)
Case InStr(1, ofld.Code, "Stakeholder:")
MsgBox GetValue(ofld)
Case InStr(1, ofld.Code, "Source:")
MsgBox GetValue(ofld)
Case InStr(1, ofld.Code, "Link to:")
MsgBox GetValue(ofld)
Case InStr(1, ofld.Code, "Maturity")
MsgBox GetValue(ofld)
Case InStr(1, ofld.Code, "Applicable SA:")
MsgBox GetValue(ofld)
Case InStr(1, ofld.Code, "Applicable LR:")
MsgBox GetValue(ofld)
Case InStr(1, ofld.Code, "Applicable A380:")
MsgBox GetValue(ofld)
End Select
End If
Next ofld
lbl_Exit:
Set ofld = Nothing
Set oPara = Nothing
Exit Sub
End Sub

Private Function GetValue(ofld As field) As String
Dim oPara As Range
Set oPara = ofld.Result.Paragraphs(1).Range
oPara.End = oPara.End - 1
oPara.Start = ofld.Result.End + 1
GetValue = oPara.Text
lbl_Exit:
Exit Function
End Function

[rkulasekaran]

Thank you graham mayor!

[rkulasekaran]

hi gmayor,

I am able to copy the contents of the values that is extracted from field to excel right now and i am trying to extract the contents from the word documents based on specific titles and their corresponding contents.
i have tried out with the following code, with the word properties for extracting the title and unable to extract the relevant contents.
I have attached a sample Document where the text highlighted in green is the title(where the last few numbers will be changing) and texts that is highlighted in yellow is the content that is to be extract. into a cell in excel



Sub InsertRow()
Dim WordApp As Object
On Error GoTo ReturnError
' Check if Word is already open
Set WordApp = GetObject(, "Word.Application")
WordApp.ActiveDocument.Content.Select
With WordApp.Selection.Find
.Text = "CA-PTS-ADIRU"
MsgBox .Text
.Wrap = wdFindStop
End With
If WordApp.Selection.Find.Execute Then
WordApp.Selection.InsertRowsBelow 1
End If
Exit Sub
ReturnError:
End Sub


please can you give any suggestions.. thanks in advance

[gmayor]

I take it we can assume that this is to be run from Excel? If so



Sub InsertRow()
Dim WordApp As Object
Dim oDoc As Object
Dim oRng As Object
Dim vRange As Variant
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
With oRng.Find
'Find the text string
Do While .Execute(FindText:="CA-PTS-ADIRU")
'Move the end of the range to the end of the paragraph
oRng.End = oRng.Paragraphs(1).Range.End - 1
'Split the paragraph at the tab character
vRange = Split(oRng.Text, Chr(9))
'Find the next empty row of the worksheet
NextRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
'And put the text in Column 1 (A)
Cells(NextRow, 1) = vRange(UBound(vRange))
'Then stop looking
Exit Do
Loop
End With
Exit Sub
ReturnError:
MsgBox "Word is not running!"
End Sub

[rkulasekaran]

Thanks for your reply gmayor!

I tried to iterate through the document to find out the next instance of
"CA-PTS-ADIRU"

I am unable to print the relevant text while iterating and also tried if multiple paragraphs are present...it takes only one..
I tried to extract between the RATIONALE field as in the word document

[gmayor]

The macro assumed one instance. If there are more than one change the code to the following, however it only extracts the first paragraph as highlighted in your example.


Sub InsertRow()
Dim WordApp As Object
Dim oDoc As Object
Dim oRng As Object
Dim vRange As Variant
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
NextRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
With oRng.Find
'Find the text string
Do While .Execute(FindText:="CA-PTS-ADIRU")
'Move the end of the range to the end of the paragraph
oRng.End = oRng.Paragraphs(1).Range.End - 1
'Split the paragraph at the tab character
vRange = Split(oRng.Text, Chr(9))
'Find the next empty row of the worksheet
'And put the text in Column 1 (A)
Cells(NextRow, 1) = vRange(UBound(vRange))
'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


with variable length texts, there is more of a problem. If we can assume that the text will always be found with the bloick that begins 'Rationale:' then we can use that e.g. as follows, but the formatting will be lost.



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

[rkulasekaran]

Thank you very much gmayor!
I tried to print all the "CA-PTS-ADIRU-XXXXX-X" values into the excel into a separate column, corresponding to the contents that is been already extracted, but unable to get!!

I tried to migrate from WORD VBA to EXCEL VBA for integrating the field values that is been extracted from word into messagebox.. i tried to copy it into the cells i.e From "C" to "L".. It is not extracting accurately.

i have pasted the code below Word VBA, please can you help me out.





Sub FindIt()
Dim blnFound As Boolean
Dim rng1 As Range
Dim rng2 As Range
Dim rngFound As Range
Dim strTheText As String
Dim xlApp As Object
Dim wbExcel As Object
Dim tSheet As Worksheet
Dim TxtRng As Range
Dim bFileSaveAs As Boolean
Dim oSheet As Object
Dim oWorkbook As Object
Dim icol As Integer
Dim Maxxx As Integer

Set xlApp = CreateObject("Excel.Application")
Set wbExcel = xlApp.Workbooks.Add
Dim NextRow As Long
'bFileSaveAs = xlApp.Dialogs(xlDialogSaveAs).Show ' Save file Dialog
xlApp.Visible = True
Set oSheet = xlApp.Sheets("Sheet1")
'MsgBox result
' Excel Alignments
'With Range("A1:N1").Rows(1)
' .Font.ColorIndex = 45
' .Font.Bold = True
' '.Font.Italic = True
' '.Font.Underline = True
' .Font.Name = "Times New Roman"
' .Font.Size = 14
' .Interior.Color = RGB(0, 0, 0)
'End With
oSheet.Cells(1, 1).Value = "Requirement number"
oSheet.Cells(1, 2).Value = "Requirement"
oSheet.Cells(1, 3).Value = "Rationale"
oSheet.Cells(1, 4).Value = "Assumptions"
oSheet.Cells(1, 5).Value = "Additional info"
oSheet.Cells(1, 6).Value = "Author"
oSheet.Cells(1, 7).Value = "Creation date"
oSheet.Cells(1, 8).Value = "Stake holder"
oSheet.Cells(1, 9).Value = "Source"
oSheet.Cells(1, 10).Value = "Link To"
oSheet.Cells(1, 11).Value = "Level"
oSheet.Cells(1, 12).Value = "Maturity"
oSheet.Cells(1, 13).Value = "Applicable SA"
oSheet.Cells(1, 14).Value = "Applicable LR"
oSheet.Cells(1, 15).Value = "Applicable A380"
'oSheet("Sheet1").Range("B2").WrapText = False

Application.ScreenUpdating = False
Selection.HomeKey wdStory
Selection.Find.text = "CA-PTS-ADIRU"
blnFound = Selection.Find.Execute
'Maxxx = ActiveDocument.Fields.Count
'For icol = 2 To 4
If blnFound Then
Selection.MoveRight wdWord
Set rng1 = Selection.Range
Selection.Find.text = "Rationale"
blnFound = Selection.Find.Execute

If blnFound Then
Set rng2 = Selection.Range
Set rngFound = ActiveDocument.Range(rng1.Start, rng2.Start)
strTheText = rngFound.text
oSheet.Cells(2, 2).Value = strTheText
End If
End If
'Next icol
Selection.HomeKey wdStory
Application.ScreenUpdating = True
'
Dim text As String
Dim result As String
text = "CA-PTS-ADIRU-AG124-1"
result = Mid(text, 1, InStr(1, text, "-AG124-1") - 1)
oSheet.Cells(2, 1).Value = result


Dim ofld As Field
Dim oPara As Range
Dim A As Variant
Dim Max As Integer
Max = ActiveDocument.Paragraphs.Count
Set oPara = ActiveDocument.Paragraphs(1).Range
oPara.End = oPara.End - 1
oPara.MoveStartUntil Chr(9)
oPara.Start = oPara.Start + 1
For irow = 2 To Max
For Each ofld In ActiveDocument.Fields
If ofld.Type = wdFieldQuote Then
Select Case True
Case InStr(1, ofld.Code, "Rationale:")
oSheet.Cells(irow, 3).Value = GetValue(ofld)
Case InStr(1, ofld.Code, "Assumptions:")
oSheet.Cells(irow, 4).Value = GetValue(ofld)
Case InStr(1, ofld.Code, "Additional info:")
oSheet.Cells(irow, 5).Value = GetValue(ofld)
Case InStr(1, ofld.Code, "Author:")
oSheet.Cells(irow, 6).Value = GetValue(ofld)
Case InStr(1, ofld.Code, "Creation date")
oSheet.Cells(irow, 7).Value = GetValue(ofld)
Case InStr(1, ofld.Code, "Stakeholder:")
oSheet.Cells(irow, 8).Value = GetValue(ofld)
Case InStr(1, ofld.Code, "Source:")
oSheet.Cells(irow, 9).Value = GetValue(ofld)
Case InStr(1, ofld.Code, "Link to:")
oSheet.Cells(irow, 10).Value = GetValue(ofld)
Case InStr(1, ofld.Code, "Level")
oSheet.Cells(irow, 11).Value = GetValue(ofld)
Case InStr(1, ofld.Code, "Maturity")
oSheet.Cells(irow, 12).Value = GetValue(ofld)
Case InStr(1, ofld.Code, "Applicable SA:")
oSheet.Cells(irow, 13).Value = GetValue(ofld)
Case InStr(1, ofld.Code, "Applicable LR:")
oSheet.Cells(irow, 14).Value = GetValue(ofld)
Case InStr(1, ofld.Code, "Applicable A380:")
oSheet.Cells(irow, 15).Value = GetValue(ofld)
End Select
End If
Next ofld
irow = irow + 1
Next irow
lbl_Exit:
Set ofld = Nothing
Set oPara = Nothing
Exit Sub
End Sub


Private Function GetValue(ofld As Field) As String
Dim oPara As Range
Set oPara = ofld.result.Paragraphs(1).Range
oPara.End = oPara.End - 1
oPara.Start = ofld.result.End + 1
GetValue = oPara.text
lbl_Exit:
Exit Function
End Function