VBA从Word文档目录中提取所有合并字段数据，并在Excel中列出它们

查找下面的代码以运行Word文档目录并提取Excel中的所有合并字段数据

您需要在工具>参考中勾选以下内容：

• Microsoft脚本运行时
• Microsoft Forms 2.0对象库*
• OLE自动化
• Visual Basic for Applications
• Microsoft Excel 15.0对象库
• Microsoft Office 15.0对象库

***如果列表中没有Microsoft Forms 2.0对象库，请点击浏览>检查您是否在System32文件夹中>选择'FM20.dll'>点击打开，它现在应该会出现在列表中以勾选

我在这个网站上找到了很多方法，所以我想分享一下我学到的东西：）

享受吧

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