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

Question

我需要一个代码来读取文件夹中所有可用的word文件并读取它们，无论它在哪里找到带有XXXX的突出显示文本，无论是日期还是任何名称，都应该将其复制并粘贴到Excel文件中的特定单元格名称“日期”中任何其他单元格的。我是 VBA 新手，但我需要有人帮助我编码。 我尝试过，但它对我不起作用。

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

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

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, StrExt As String, wdDoc As Document
Dim i As Long, r As Long
'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
  ' The file is available, so open it.
  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
          .Format = False
          .MatchCase = False
          .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 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 工作簿中。