1

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

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

  • Microsoft 脚本运行时
  • Microsoft Forms 2.0 对象库*
  • OLE 自动化
  • 应用程序的 Visual Basic
  • Microsoft Excel 15.0 对象库
  • Microsoft Office 15.0 对象库

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

我用这个网站来研究如何做很多这样的事情，所以我想我会分享我学到的东西:)

享受！

4

1 回答 1

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
于 2014-02-03T11:30:22.927 回答