Microsoft Word VBA查找具有多个页面的文档中单个指定页面上出现的单词数量

我正在努力开发代码，作为更大代码集的一部分使用，最终将回答一个特定单词在一个word文档中的一个指定页面上出现多少次，该文档中可能有许多页面

代码实际上试图完成的是一次只在一个页面上搜索一个短语，找到该短语，然后在该页面上找到该短语的位置后立即复制字符串，并将字符串粘贴到另一个word文档中。如果你能想出一个比我下面的更好的方法，我愿意改变现状，因为这比我一开始想象的要困难得多

Sub test()

'Find and Define Documents
Dim doc As Document
For Each doc In Documents
       If Left(doc.Name, 5) = "LEGAL" Then
       Dim MainDoc As Document
       Set MainDoc = doc
    End If
Next doc

For Each doc In Documents
    If doc.Name = "Document1" Then
       Dim OtherDoc As Document
       Set OtherDoc = doc
    End If
Next doc

'Start from top of main doc.
MainDoc.Activate
Selection.GoTo What:=(0)

'count # of pages in main doc. 
Dim iCount As Integer
iCount = 0

'Do for other procedures to be accomplished in the code
Do While iCount < ActiveDocument.BuiltInDocumentProperties("Number of Pages")
iCount = iCount + 1
MainDoc.Activate
Dim Range_Doc As Range
Set Range_Doc = MainDoc.GoTo(What:=wdGoToPage, Name:=iCount)
Set Range_Doc = Range_Doc.GoTo(What:=wdGoToBookmark, Name:="\page")

'Find & Count the number of times the word Apple appears on specific page
    Dim AppleCount As Integer
    If AppleCount > 0 Then
        Dim OriginalCount As Integer
        OriginalCount = AppleCount
    End If

    AppleCount = 0

   Range_Doc.Bookmarks("\page").Range.Select
    'Selection.MoveRight Unit:=wdCharacter, Count:=1
    With Selection.Find
        .Text = "Apple"
        .Format = False
        .Wrap = 0
        .Forward = False

      Do While .Execute
        AppleCount = AppleCount + 1
      Loop
    End With

    Dim NewCount As Integer
    NewCount = AppleCount - OriginalCount

    If NewCount < 0 Then
        NewCount = 0
    End If


    'Locate where in the doc the find term was found and extract what is coming after it
    Set Range_Doc = MainDoc.GoTo(What:=wdGoToPage, Name:=iCount)
    Set Range_Doc = Range_Doc.GoTo(What:=wdGoToBookmark, Name:="\page")

    Dim objFind As Find
    Set objFind = Range_Doc.Find
    With Range_Doc.Find
       Counter = 0
       Do While .Execute(findText:="Apple", MatchWholeWord:=False, Forward:=True) = True And Counter < NewCount

       With Range_Doc
          Set objFind = Range_Doc.Find

          If objFind.Found Then
             Dim Range_Found As Range
             Set Range_Found = objFind.Parent

             Dim IntPos as Integer
             IntPos = Range_Found.End

             Dim AppleID
             Set AppleID = MainDoc.Range(Start:=IntPos, End:=IntPos + 33)

             OtherDoc.Content.InsertAfter ","
             OtherDoc.Content.InsertAfter AppleID

          End If

        End With
        Counter = Counter + 1
        Loop
    End With

Loop
End sub

子测试（）
'查找和定义文档
将文档变为文档
对于文档中的每个文档
如果左（文件名，5）=“合法”，则
将主文档作为文档
设置MainDoc=doc
如果结束
下一个医生
对于文档中的每个文档
如果doc.Name=“Document1”，则
将其他文档设置为文档
设置OtherDoc=doc
如果结束
下一个医生
'从主文档顶部开始。
MainDoc.Activate
Selection.GoTo What:=（0）
“主文档中的页面计数”。
Dim I以整数形式计数
i计数=0
“对于代码中要完成的其他程序，请执行以下操作
在iCount0，则
Dim OriginalCount作为整数
OriginalCount=AppleCount
如果结束
AppleCount=0
Range\u Doc.书签（“\page”）。Range.Select
'Selection.MoveRight单位：=wdCharacter，计数：=1
选择。查找
.Text=“苹果”
.Format=False
.Wrap=0
.Forward=False
执行，执行
AppleCount=AppleCount+1
环
以
将NewCount设置为整数
NewCount=AppleCount-OriginalCount
如果NewCount<0，则
NewCount=0
如果结束
'查找文档中查找术语的位置，并提取其后面的内容
设置范围\u Doc=MainDoc.GoTo（What:=wdGoToPage，Name:=iCount）
设置范围\u Doc=Range\u Doc.GoTo（内容：=wdGoToBookmark，名称：=“\page”）
Dim objFind作为Find
设置objFind=Range\u Doc.Find
使用范围_Doc.Find
计数器=0
执行（findText:=“Apple”，MatchWholeWord:=False，Forward:=True）=True，计数器

可能是基于：

Sub Demo()
Application.ScreenUpdating = False
Dim DocSrc As Document, DocTgt As Document, Rng As Range
Set DocSrc = ActiveDocument: Set DocTgt = Documents.Add
With DocSrc
  Set Rng = .Range.GoTo(What:=wdGoToPage, Name:=3)
  Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\page")
  With Rng.Duplicate
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = "Apple"
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
      .Format = False
      .MatchCase = True
      .MatchWholeWord = True
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
      .Execute
    End With
    Do While .Find.Found
      If .InRange(Rng) = False Then Exit Do
      .Collapse wdCollapseEnd
      .End = .Paragraphs(1).Range.End -1
      DocTgt.Range.Characters.Last.Text = vbCr & .Text
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
End With
Application.ScreenUpdating = True
End Sub

---

您感兴趣的内容在第3页。

文档没有页面。仅打印相同的渲染。更改字体大小或边距，页面将发生更改。文件有章节、段落、句子和单词。这是一种严重的过度简化。事实是,，Word文档中的内容可以按页面进行处理，正如OP的代码所示demonstrates@Taylor_D从您的代码中看不出在页面中循环的意义是什么-它似乎对输出没有贡献。因此，发生的情况是，在同一个文档中有多个相同的表单发送给我们。第1页是一张表格第2页是一张新表格第3页和第4页是同一张表格，因为有更多的信息转到下一页。这又持续了80多页。所以我要做的是循环浏览所有页面，从每个表单中只提取我需要的信息。我可以这样做，因为在我需要提取的信息之前，每个表单都有一组独特的单词。因此，我在每一页中循环，找到我正在搜索的术语，然后将紧跟其后的术语复制并粘贴到不同的文档中。问题来自于这些相同的术语有时会出现不止一次，因此我需要在每个页面内循环，以提取搜索术语后面的每个术语。让我知道这是否更有意义。我现在不在电脑旁，但我回来后会试试。感谢您的帮助，我们将在上午跟进。再次感谢你，它确实比我的方法干净多了！非常感谢你。对于那些感兴趣的人，我也找到了另一个解决方案，那就是在进行选择之前只选择页面。通过使用`Selection.GoTo wdGoToPage，wdGoToAbsolute，iCount | Selection.Bookmarks（“\page”）进行查找。选择`using Selections低效且容易产生屏幕闪烁。我同意。我实施了你的解决方案。干净多了。很好的工作，再次感谢朋友。有没有办法写这部分。End=.End+33如果说我不知道这将是一个保证的33个字符，只是想把所有的东西都拉到一行或一段的末尾？