If the above code does not help you to extract data from Microsoft word than try this code. I am sure this will help. I have personally edited for you. So you just need to copy paste the below vba code.
Code:
Sub ExtractData()
Dim sDTE As String
Dim sSubject As String
Dim strFileName As String
Dim strPath As String
Dim oDoc As Document
Dim dataDoc As Document
Dim fDialog As FileDialog
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
'Pick the folder with the letters
With fDialog
.Title = "Select Folder containing the documents to be modifed and click OK"
.AllowMultiSelect = False
.InitialView = msoFileDialogViewList
If .Show <> -1 Then
MsgBox "Cancelled By User"
Exit Sub
End If
strPath = fDialog.SelectedItems.Item(1)
If Right(strPath, 1) <> "\" Then strPath = strPath + "\"
End With
'Close any open documents
If Documents.Count > 0 Then
Documents.Close SaveChanges:=wdPromptToSaveChanges
End If
strFileName = Dir$(strPath & "*.do?")
'Assign the name of the document to take the data
Documents.Open ("""D:\My Documents\Test\DTE data.doc""")
Set dataDoc = ActiveDocument
'Open the letters in turn
While strFileName <> ""
Set oDoc = Documents.Open(strPath & strFileName)
Selection.HomeKey wdStory 'Start from the top of the letter
With Selection.Find 'find the first string
.ClearFormatting
Do While .Execute(findText:="DTE/*^13", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True
'Assign the found text to a variable and chop off
'the last character -
sDTE = Left(Selection.Range, Len(Selection.Range) - 1)
Loop
End With
Selection.HomeKey wdStory 'Start from the top of the letter
With Selection.Find 'find the second string
.ClearFormatting
Do While .Execute(findText:="Subject :*^13", _
MatchWildcards:=True, _
Wrap:=wdFindStop, Forward:=True) = True
'Assign the second string to a variable and chop off
'the last character and the leading text
sSubject = Mid(Selection.Range, 10, Len(Selection.Range) - 10)
Loop
End With
'Switch to the data document and add the content of
'the variables to the blank row of the table
dataDoc.Activate
With Selection
.EndKey wdStory
.MoveUp Unit:=wdLine, Count:=1
.MoveRight Unit:=wdCell, Count:=2 'Add a new blank row
.TypeText Text:=sDTE
.MoveRight Unit:=wdCell
.TypeText Text:=sSubject
End With
'Close the letter without saving
oDoc.Close SaveChanges:=wdDoNotSaveChanges
Set oDoc = Nothing
strFileName = Dir$()
Wend
'Save the data document
dataDoc.Save
End Sub
Bookmarks