使用Excel VBA搜索Word文档中的每个标题？

Question

因此，我有下面的代码（非常丑陋），我需要使用该代码打开指定的Word文档，在每页的页眉中搜索特定值，然后打印找到该页的页面。

我的问题是，当前仅在打开文档时搜索第一页，但是每个文档大约需要搜索400页。

Private Sub CommandButton1_Click()
    Dim i As Integer
    i = 2
    Do While Cells(i, 1).Value <> ""
        Set wdApp = CreateObject("Word.Application")
        wdApp.Visible = True
        wdApp.documents.Open ("\\Location" & Cells(i, 9) & ".docx")

        Dim Sctn As Section, HdFt As HeadersFooters
        Dim FindWord As String
        FindWord = Cells(i, 11).Value

        wdApp.Selection.WholeStory
        wdApp.Selection.Find.ClearFormatting

        For Each Sctn In wdApp.ActiveDocument.Sections
            For Each HdFt In Sctn.Headers(wdHeaderFooterPrimary)
                With wdApp.Selection.Find          
                    .Text = FindWord
                    .Forward = True
                    .Wrap = wdFindContinue
                    .Format = False
                    .MatchCase = False
                    .MatchWholeWord = True
                    .MatchWildcards = False
                    .MatchSoundsLike = False
                    .MatchAllWordForms = False

                    If .Execute Then
                        Cells(i, 12).Value = "Yes"
                    Else
                        Cells(i, 12).Value = "No"
                    End If
                End With
            Next
        Next
        wdApp.Quit

        i = i + 1
    Loop
End Sub

目前，我可以告诉我“是”或“否”以节省数据，以节省打印时间。

非常感谢您能够提供的任何帮助或指针。

Answer 1

您的代码效率低下主要是由于不必要的重复创建和销毁Word会话造成的。 您还使用命名的Word常量，它与CreateObject（“ Word.Application”）暗示的后期绑定不一致。 您需要了解的另一件事（如Cindy所指出的）是Sections（而不是页面）具有标题。 另外，标题可以链接到前面的部分，在这种情况下，它们不需要单独的测试。 由于您尝试查找的内容可能位于任何Section的主标题中，因此最好使用StoryRanges集合。 尝试：

Private Sub CommandButton1_Click()
Dim ObjWrd As Object, ObjDoc As Object, ObjSctn As Object, ObjHdFt As Object
Dim xlWkSht As Worksheet, r As Long
Set xlWkSht = activesheet: i = 2
Set ObjWrd = CreateObject("Word.Application")
With ObjWrd
  .Visible = True
  Do While xlWkSht.Cells(r, 1).Value <> ""
    Set ObjDoc = wdApp.Documents.Open("\\Location" & Cells(i, 9) & ".docx", False, True, False)
    With ObjDoc
      With .StoryRanges(7).Find '7 = wdPrimaryHeaderStory
        .ClearFormatting
        .Text = Cells(i, 11).Value
        .Forward = True
        .Wrap = 0 '0 = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute
        If .Found = True Then
          xlWkSht.Cells(r, 12).Value = "Yes"
        Else
          xlWkShtCells(r, 12).Value = "No"
        End If
      End With
      .Close False
    End With
    r = r + 1
  Loop
  .Quit
End With
End Sub

要注意的另一件事是，Word文档的每个节都有三个页眉和页脚（偶数页，首页和主要页）。 上面的代码仅搜索Primary标头。 如果您还想搜索其他人，则需要如下代码：

Private Sub CommandButton1_Click()
Dim ObjWrd As Object, ObjDoc As Object, ObjSctn As Object, ObjHdFt As Object
Dim xlWkSht As Worksheet, r As Long, i As Long
Set xlWkSht = activesheet: i = 2
Set ObjWrd = CreateObject("Word.Application")
With ObjWrd
  .Visible = True
  Do While xlWkSht.Cells(r, 1).Value <> ""
    xlWkShtCells(r, 12).Value = "No"
    Set ObjDoc = wdApp.Documents.Open("\\Location" & Cells(i, 9) & ".docx", False, True, False)
    With ObjDoc
      For i = 6 To 10
        Select Case i
          Case 6, 7, 10 '6 = wdEvenPagesHeaderStory, 7 = wdPrimaryHeaderStory, 10 = wdFirstPageHeaderStory
            With .StoryRanges(i).Find
              .ClearFormatting
              .Text = Cells(i, 11).Value
              .Forward = True
              .Wrap = 0 '0 = wdFindStop
              .Format = False
              .MatchCase = False
              .MatchWholeWord = True
              .MatchWildcards = False
              .MatchSoundsLike = False
              .MatchAllWordForms = False
              .Execute
              If .Found = True Then
                xlWkSht.Cells(r, 12).Value = "Yes"
                Exit For
              End If
            End With
          Case Else 'Do nothing
        End Select
      .Close False
    End With
    r = r + 1
  Loop
  .Quit
End With
End Sub