VBA Extract all Merge Fields data from Directory of Word Docs and list them in Excel

Question

Find below code to Run through a directory of Word Documents and extract all of the merge field data in Excel.

You will need the following ticked in Tools > References:

• Microsoft Scripting Runtime
• Microsoft Forms 2.0 Object Library *
• OLE Automation
• Visual Basic for Applications
• Microsoft Excel 15.0 Object Library
• Microsoft Office 15.0 Object Library

*** if Microsoft Forms 2.0 Object Library isn't in the list, hit Browse > check you are in the System32 Folder > Select 'FM20.dll' > hit Open and it should now appear in the list to tick.

I used this site to work out how to do a lot of this so I thought I'd share what I learned :)

Enjoy!

Answer 1

Code:

Sub GetTextFromWord()

'Run this code from EXCEL only
'KILL WINWORD.EXE BEFORE YOU START!!!

'This macro extracts all the Merge Fields in a Directory and records them in the Active Excel Sheet.
'Note - this will only search the folder you specify, it will not search sub-folders
'Finally, make sure the folder you are copying from only contains Word files (.doc/.docx/.dot etc) or this will crash.
'
'Have your Folder Path ready in the Clipboard, then hit Run
'It might take a short while depending on the size of the directory, but shouldn't be more than a few minutes.
'Best to leave the computer alone while it runs, but especially don't try to use word or copy/paste functions.

Dim Paragraph As Object, WordApp As Object, WordDoc As Object

Dim msg As String
Dim FSO As New Scripting.FileSystemObject
Dim FieldsData As DataObject
Dim sourceCol As Integer, rowCount As Integer, currentRow As Integer
Dim currentRowValue As String
Dim Folder As String
Dim ext As String
Dim file1
Dim Path As String


Application.ScreenUpdating = True
Application.DisplayAlerts = False

Path = InputBox("Paste Folder Path Now")
Folder = (Path & "\")
'MsgBox Folder


Set WordApp = CreateObject("Word.Application")
WordApp.Visible = False
'MsgBox Folder

For Each fl In FSO.GetFolder(Folder).Files

Set WordDoc = WordApp.Documents.Open(fl.Path)
'Application.Wait (Now + TimeValue("0:00:03"))



    If WordApp.ActiveDocument.Fields.Count > 0 Then
        For Each aField In WordApp.ActiveDocument.Fields

        msg = msg & aField.Code & vbCrLf
        Next
        Set FieldsData = New DataObject
        FieldsData.SetText (msg)
        FieldsData.PutInClipboard
        'MsgBox msg

Range("B2").Select
ActiveSheet.Paste
Selection.End(xlDown).Select
ActiveCell.Offset(1).Select
End If
WordDoc.Close

Next

WordApp.Quit

'Tidy up and leave only unique results in Workbook
Columns("B:B").Select
ActiveSheet.Range("B:B").RemoveDuplicates Columns:=1, Header:=xlYes
Range("B2").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1).Select

End Sub



Private Sub Worksheet_SelectionChange(ByVal Target As Range)

End Sub