Get specific text from Word document & paste into Excel

Question

I have to fetch specific data from many Word documents in sub-folders & paste into the next cell. For ex: First page of document contains "Application id= 1234" & next Word document first page contains "Application id=4563". I want those application id's to a new cell in Excel under B column.

When I tried using the below code, I got the whole first page data in a column.

Option Explicit

Dim FSO As Object
Dim strFolderName As String
Dim FileToOpenVdocx As String
Dim FileToOpenvdoc1 As String
Dim FileToOpenVdoc As String
Dim FileToOpenvdocx1 As String
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim fsoFolder As Object

 'To copy data from word to excel

   'Copy data from word to excel


Sub FindFilesInSubFolders()
Dim fsoFolder As Scripting.Folder
Sheets("Sheet1").Cells.Clear
FileToOpenVdocx = "*V2.1.docx*"
FileToOpenvdoc1 = "*v2.1.doc*"
FileToOpenVdoc = "*V2.1.doc*"
FileToOpenvdocx1 = "*v2.1.docx*"

If FSO Is Nothing Then
   Set FSO = CreateObject("Scripting.FileSystemObject")
End If

'Set the parent folder for the new subfolders
strFolderName = "C:\Test1"

Set fsoFolder = FSO.GetFolder(strFolderName)
Set wrdApp = CreateObject("Word.Application")

OpenFilesInSubFolders fsoFolder
wrdApp.Quit
End Sub

Sub OpenFilesInSubFolders(fsoPFolder As Scripting.Folder)
Dim fsoSFolder As Scripting.Folder
Dim fileDoc As Scripting.File
Dim wrdRng As Object
Dim strText As String
'Dim outRow As Long ' newly added

   'outRow = 1 'you appear to want to start at the second row

For Each fsoSFolder In fsoPFolder.SubFolders
For Each fileDoc In fsoSFolder.Files

        If fileDoc.Name Like FileToOpenVdocx And Left(fileDoc.Name, 1) <> "~" Then
        Set wrdDoc = wrdApp.Documents.Open(fileDoc.Path)
        Set wrdRng = wrdDoc.Content

           If wrdRng.Find.Execute(FindText:="Application ID:[0-9]{1,}", MatchWildcards:=True) = True Then
    MsgBox "Text not found!", vbExclamation
    End If
     strText = wrdRng.Text

     'Cells(outRow & "B").Value = strText 'newly added
        'outRow = outRow + 1 'newly added

       Range("B2").Value = strText

        With wrdApp
           .ActiveDocument.Tables(1).Select
           .Selection.Copy
           ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, "D").End(xlUp)(1).PasteSpecial xlPasteValues
       End With
       wrdDoc.Close False
       'wrdApp.Quit

       ElseIf fileDoc.Name Like FileToOpenvdoc1 And Left(fileDoc.Name, 1) <> "~" Then
       Set wrdDoc = wrdApp.Documents.Open(fileDoc.Path)

        With wrdApp
           .ActiveDocument.Tables(1).Select
           .Selection.Copy
           ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, "D").End(xlUp)(1).PasteSpecial xlPasteValues
       End With
       wrdDoc.Close False

       ElseIf fileDoc.Name Like FileToOpenVdoc And Left(fileDoc.Name, 1) <> "~" Then
       Set wrdDoc = wrdApp.Documents.Open(fileDoc.Path)

        With wrdApp
           .ActiveDocument.Tables(1).Select
           .Selection.Copy
           ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, "D").End(xlUp)(1).PasteSpecial xlPasteValues
       End With
       wrdDoc.Close False

       ElseIf fileDoc.Name Like FileToOpenvdocx1 And Left(fileDoc.Name, 1) <> "~" Then
       Set wrdDoc = wrdApp.Documents.Open(fileDoc.Path)

        With wrdApp
           .ActiveDocument.Tables(1).Select
           .Selection.Copy
           ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, "D").End(xlUp)(1).PasteSpecial xlPasteValues
       End With
       wrdDoc.Close False
      End If
    Next fileDoc
   'Debug.Print fsoSFolder

   OpenFilesInSubFolders fsoSFolder
Next fsoSFolder
End Sub

Answer 1

I have not so many input documents. So, I can't test your whole code. But I got one for you. I prepare a document like your input. And I tested with the following code. It returns the id which we desired. So, you can try with this. I believe that the code will be helpful for you.

Public Sub getID()

    Dim found As Integer
    Dim resultId As String

    Set wordApp = CreateObject("word.Application")

    wordApp.documents.Open ThisWorkbook.Path & "\ID1.docx"

    wordApp.Visible = True

    'Loop all content in line by line from paragraph of active document
    For Each singleLine In wordApp.ActiveDocument.Paragraphs

        'Search "Application ID" in line.
        'If found, value will be greater 0.
        found = InStr(singleLine, "Application ID")

        'If Application ID is found, get ID only
        If found > 0 Then

            'If you want the whole line, try as "resultId = singleLine"
            'The below line is separating id from that string.

            'Get ID by replacing the prefix with space.
            resultId = Trim(Replace(singleLine, "Application ID:", ""))

            MsgBox resultId

            'After getting, stop loop because not need
            Exit For

        End If

    Next singleLine

End Sub

Answer 2

Try replacing:

Range("B2").Value = strText

with

Range("B2").Value = "Application ID: " & Right(Left(strText, Instr(strText, "Application ID") + 19),4)

This only works though if your ID is always 4 digits long.

ps. I didn't try the code myself, so let me know if it works.

Or you can have a look at this: How to find numbers from a string? and combine it with some string length manipulation as I did in my answer.