Sub 按指定的字体和字号在 Word 文档中查找文本

Question

目标：通过字体和字号在文档中查找标题并将它们放入电子表格中。

我的文档中的所有标题都格式化为 Ariel，大小为 16。我想查找 Word 文档，选择匹配的文本范围到行尾，然后将其分配给一个变量，以便我可以输入它在电子表格中。我可以成功地进行高级查找和搜索字体/大小，但无法让它选择文本范围或将其分配给变量。

尝试从http://www.vbaexpress.com/forum/showthread.php?55726-find-replace-fonts-macro 修改以下内容，但无法弄清楚如何选择找到的文本并将其分配给变量。如果我可以将其分配给变量，那么我可以处理其余部分，将其放入电子表格中。

'A basic Word macro coded by Greg Maxey
Sub FindFont

Dim strHeading as string
Dim oChr As Range

  For Each oChr In ActiveDocument.Range.Characters
    If oChr.Font.Name = "Ariel" And oChr.Font.Size = "16" Then
      strHeading = .selected
  Next

lbl_Exit:
  Exit Sub

End Sub

Answer 1

要使当前代码正常工作，您只需将strHeading = .selected 修改为strHeading = strHeading & oChr & vbNewLine 之类的内容。您还需要在该行之后添加一个End If 语句，并可能将"Ariel" 修改为"Arial"。

我认为更好的方法是使用 Word 的 Find 方法。根据您将数据插入电子表格的方式，您可能还希望将找到的每个标题放在集合中而不是字符串中，尽管您可以轻松地分隔字符串，然后在将数据传输到电子表格。

为了给你更多的想法，我在下面放了一些示例代码。

Sub Demo()
    Dim Find As Find
    Dim Result As Collection
    
    Set Find = ActiveDocument.Range.Find
    
    With Find
        .Font.Name = "Arial"
        .Font.Size = 16
    End With

    Set Result = Execute(Find)
    
    If Result.Count = 0 Then
        MsgBox "No match found"
        Exit Sub
    Else
        TransferToExcel Result
    End If
End Sub

Function Execute(Find As Find) As Collection
    Set Execute = New Collection
    
    Do While Find.Execute
        Execute.Add Find.Parent.Text
    Loop
End Function

Sub TransferToExcel(Data As Collection)
    Dim i As Long
    
    With CreateObject("Excel.Application")
        With .Workbooks.Add
            With .Sheets(1)
                For i = 1 To Data.Count
                    .Cells(i, 1) = Data(i)
                Next
            End With
        End With
        .Visible = True
    End With
End Sub