Unable to extract the field values in Word RRS feed

  • Question

  • 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


    Thursday, June 4, 2015 11:25 AM

All replies

  • I'm not sure what you mean by 'field datas' but try one of the below Macros and see if these do what you want.

    Sub GetWordDocContents()
      Dim oWord As Object
      Dim vFiles
      Dim iFile As Integer
      Dim r As Range
      Dim LastRow As Long
      vFiles = Application.GetOpenFilename("Word files (*.doc*),*.doc*", Title:="Please select the files you want to copy from", MultiSelect:=True)
      If TypeName(vFiles) = "Boolean" Then Exit Sub ' Cancelled
      Set oWord = CreateObject("Word.Application")
      oWord.Visible = True
      Set r = ActiveSheet.Range("A1")
      For iFile = LBound(vFiles) To UBound(vFiles)
        oWord.Documents.Open vFiles(iFile)
        ActiveSheet.Paste r
        r.Offset(0, 6).Value = oWord.ActiveDocument.Name
        Set r = Cells(ActiveSheet.UsedRange.Rows.Count + 1, 1)
        oWord.ActiveDocument.Close False
      Set oWord = Nothing
        ' Delete row if blank
        For LastRow = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
           If Cells(LastRow, 1) = "" Then Rows(LastRow).Delete
        Next LastRow
    End Sub

    Sub CreateWordDoc()
        Dim wdApp As Object
        Dim wdDoc As Object
        Dim rCell As Range
        Dim rRng As Range
        Dim lScore As Long
        Dim sName As String
        Set rRng = Sheet1.Range("A2:A6")
        lScore = 100  'set the max possible score
        'loop through the range
        For Each rCell In rRng.Cells
            'if the score is less than previous
            If rCell.Offset(0, 1).Value < lScore Then
                'store the data as variables
                lScore = rCell.Offset(0, 1).Value
                sName = rCell.Value
            End If
        Next rCell
        'open the word documents
        Set wdApp = CreateObject("Word.Application")
        Set wdDoc = wdApp.Documents.Open("C:\Documents and Settings\AutoWord.doc")
        'replace the bookmarks with the variables
        FillBookmark wdDoc, sName, "bmWinner"
        FillBookmark wdDoc, lScore, "bmScore", "0"
        'show the word document
        wdApp.Visible = True
    End Sub
    Sub FillBookmark(ByRef wdDoc As Object, _
        ByVal vValue As Variant, _
        ByVal sBmName As String, _
        Optional sFormat As String)
        Dim wdRng As Object
        'store the bookmarks range
        Set wdRng = wdDoc.Bookmarks(sBmName).Range
        'if the optional format wasn’t supplied
        If Len(sFormat) = 0 Then
            'replace the bookmark text
            wdRng.Text = vValue
            'replace the bookmark text with formatted text
            wdRng.Text = Format(vValue, sFormat)
        End If
        're-add the bookmark because the above destroyed it
        wdRng.Bookmarks.Add sBmName, wdRng
    End Sub

    Sub OpenAndReadWordDoc()
    ' assumes that the previous procedure has been executed
    Dim wrdApp As Word.Application
    Dim wrdDoc As Word.Document
    Dim tString As String, tRange As Word.Range
    Dim p As Long, r As Long
        Workbooks.Add ' create a new workbook
        With Range("A1")
            .Formula = "Word Document Contents:"
            .Font.Bold = True
            .Font.Size = 14
            .Offset(1, 0).Select
        End With
        r = 3 ' startrow for the copied text from the Word document
        Set wrdApp = CreateObject("Word.Application")
        'wrdApp.Visible = True
        Set wrdDoc = wrdApp.Documents.Open("C:\Temp\MyNewWordDoc.doc")
        ' example word operations
        With wrdDoc
            For p = 1 To .Paragraphs.Count
                Set tRange = .Range(Start:=.Paragraphs(p).Range.Start, _
                tString = tRange.Text
                tString = Left(tString, Len(tString) - 1)
                ' exclude the paragraph-mark
                ' check if the text has the content you want
                If InStr(1, tString, "1") > 0 Then
                    ' fill into active worksheet
                    ActiveSheet.Range("A" & r).Formula = tString
                    r = r + 1
                End If
            Next p
            .Close ' close the document
        End With
        wrdApp.Quit ' close the Word application
        Set wrdDoc = Nothing
        Set wrdApp = Nothing
        ActiveWorkbook.Saved = True
    End Sub

    Finally . . . . . . .

    Send Word Data to Excel:
    Sub CreateNewExcelWB()
    ' to test this code, paste it into a Word module
    ' add a reference to the Excel-library
    ' create a new folder named C:\Foldername or edit the filnames in the code
    Dim xlApp As Excel.Application
    Dim xlWB As Excel.Workbook
    Dim i As Integer
        Set xlApp = CreateObject("Excel.Application")
        xlApp.Visible = True
        Set xlWB = xlApp.Workbooks.Add ' create a new workbook
        ' or
        'Set xlWB = xlApp.Workbooks.Open("C:\Foldername\Filename.xls")
        ' open an existing workbook
        ' example excel operations
        With xlWB.Worksheets(1)
            For i = 1 To 100
                .Cells(i, 1).Formula = "Here is a example test line #" & i
            Next i
            .SaveAs ("C:\TEMP\MyNewExcelWB.xls")
        End With
        xlWB.Close False ' close the workbook without saving
        xlApp.Quit ' close the Excel application
        Set xlWB = Nothing
        Set xlApp = Nothing
    End Sub

    Knowledge is the only thing that I can give you, and still retain, and we are both better off for it.

    Thursday, June 4, 2015 5:03 PM
  • This thread was also created and answered at

    Please crosspost duplicated messages to avoid unnecessary duplication of effort.

    Graham Mayor - Word MVP

    Friday, June 5, 2015 6:17 AM