将 Word 文件中突出显示的文本复制到不同单元格下的一张 Excel 工作表中

Question

我需要读取一个文件夹中的所有Word文件。只要有带有 XXXX 的突出显示文本，无论是日期还是任何名称，都应将其复制到 Excel 文件中该特定单元格名称中的任何其他单元格的日期。

Sub ExtractHighlightedText()

    Dim oDoc As Document
    Dim s As String
    With Selection
        .HomeKey Unit:=wdStory 
        With .Find
            .ClearFormatting
            .Text = ""
            .Highlight = True
            Do While .Execute
                s = s & Selection.Text & vbCrLf
            Loop
        End With
    End With
    Set oDoc = Documents.Add 
    oDoc.Range.InsertAfter s 

End Sub

Answer 1

您的要求还很不明确。但是，以下 Word 宏应该可以帮助您入门：

Sub BulkExportHilites()
'NOTE: This code requires a VBA reference to Excel
'to be set, via Tools|References in the VBE
Application.ScreenUpdating = False
Application.DisplayAlerts = wdAlertsNone
Application.WordBasic.DisableAutoMacros True
Dim strFolder As String, strFile As String, strDocNm As String
Dim r As Long, wdDoc As Document
'Get the folder to process
strFolder = GetFolder
If strFolder = "" Then Exit Sub
'Start Excel
Dim xlApp As New Excel.Application, xlWkBk As Excel.Workbook, xlWkSht As Excel.Worksheet
With xlApp
  'Hide our Excel session
  .Visible = False
  Set xlWkBk = .Workbooks.Add
End With
strDocNm = ActiveDocument.FullName
'Process each document in the folder
strFile = Dir(strFolder & "\*.doc", vbNormal)
Do While strFile <> ""
  If strFolder & "\" & strFile <> strDocNm Then
    Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
    Set xlWkSht = xlWkBk.Sheets.Add: r = 0: xlWkSht.Name = strFile
    With wdDoc
      With .Range
        With .Find
          .Text = ""
          .Forward = True
          .Wrap = wdFindStop
          .Highlight = True
        End With
        Do While .Find.Execute
          r = r + 1
          xlWkSht.Cells(r, 1).Value = .Text
          .Collapse wdCollapseEnd
        Loop
      End With
      .Close SaveChanges:=False
    End With
  End If
  strFile = Dir()
Loop
xlWkBk.Sheets("Sheet1").Delete: xlApp.Visible = True
Set xlWkSht = Nothing: Set xlWkBk = Nothing: Set xlApp = Nothing: Set wdDoc = Nothing
Application.WordBasic.DisableAutoMacros False
Application.DisplayAlerts = wdAlertsAll
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

上述代码循环遍历所选文件夹中的所有Word文档，将文档正文中找到的所有突出显示内容（不是页眉/页脚/文本框/脚注/尾注）输出到新Excel工作簿中具有相应文档名称的工作表。

如果您希望所有输出都在同一个工作表上，请使用：

Sub BulkExportHilites()
'NOTE: This code requires a VBA reference to Excel
'to be set, via Tools|References in the VBE
Application.ScreenUpdating = False
Application.DisplayAlerts = wdAlertsNone
Application.WordBasic.DisableAutoMacros True
Dim strFolder As String, strFile As String, strDocNm As String
Dim r As Long, c As Long, wdDoc As Document
'Get the folder to process
strFolder = GetFolder
If strFolder = "" Then Exit Sub
'Start Excel
Dim xlApp As New Excel.Application, xlWkBk As Excel.Workbook, xlWkSht As Excel.Worksheet
With xlApp
  'Hide our Excel session
  .Visible = False
  Set xlWkBk = .Workbooks.Add
End With
strDocNm = ActiveDocument.FullName: Set xlWkSht = xlWkBk.Sheets(1): c = 0
'Process each document in the folder
strFile = Dir(strFolder & "\*.doc", vbNormal)
Do While strFile <> ""
  If strFolder & "\" & strFile <> strDocNm Then
    Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
    r = 1: c = c + 1: xlWkSht.Cells(r, c).Value = strFile
    With wdDoc
      With .Range
        With .Find
          .Text = ""
          .Forward = True
          .Wrap = wdFindStop
          .Highlight = True
        End With
        Do While .Find.Execute
          r = r + 1
          xlWkSht.Cells(r, c).Value = .Text
          .Collapse wdCollapseEnd
        Loop
      End With
      .Close SaveChanges:=False
    End With
  End If
  strFile = Dir()
Loop
xlApp.Visible = True
Set xlWkSht = Nothing: Set xlWkBk = Nothing: Set xlApp = Nothing: Set wdDoc = Nothing
Application.WordBasic.DisableAutoMacros False
Application.DisplayAlerts = wdAlertsAll
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function