为什么 .Find 函数在此代码中似乎无法正常工作？

Question

该程序应该遍历一个目录，以从另一个 word 文档中的列表中查找每个出现的单词，并将选择范围扩展到整个问题。该程序应该允许您根据高度相关的关键术语列表从测试库中编译测试问题列表。最终，一旦选择了所有相关问题，它们将被复制到新文档中。

Sub CompareWordList()
'program to loop through Directory to find every occurrence of a word from a list and expand selection to
'the whole question. This program is supposed to allow you to compile a list of test questions from a
'test bank based on a list of highly relevent key terms. Eventually, once all the relevent questions are selected
'They would be copied to a new document
'variables for directory looping
Dim vDirectory As String
Dim oDoc As Document

'generates file path
vDirectory = "D:\school\documents\MGT450\Test_Bank\TB - test\" 'set directory to loop through

vFile = Dir(vDirectory & "*.*") 'file name

'variables for selection
Dim sCheckDoc As String
Dim docRef As Document
'Dim docCurrent As Document
Dim wrdRef As Object

 'list of words to look for
sCheckDoc = "D:\testlist.docx"
Set docRef = Documents.Open(sCheckDoc)
'docCurrent.Activate
docRef.Activate
'Directory Loop
Do While vFile <> ""
    Set oDoc = Documents.Open(FileName:=vDirectory & vFile)
'document activation
oDoc.Activate
SendDocToArray_FindWords (sCheckDoc)





'Havent really worked on this area yet, as been focused on find issue
docRef.Close
'close document modification

    oDoc.Close SaveChanges:=False
    vFile = Dir
Loop
End Sub
'After every instance of a particular phrase is selected, select question 
around said phrase
Function SelectQuestion(Index As Long)
'iniitial declaration
Dim linecount As Integer
Set mydoc = ActiveDocument
Dim oPara As word.Paragraph
'Dim oPara As selection
Dim ListLevelNumber As Integer
Dim holder As Long

    'if list type is simple numbering
    If selection.Range.ListFormat.ListType = wdListSimpleNumbering Or 
 wdListBullet Or wdListMixedNumbering Then
        'Select Whole Question containing word
        With selection
         .StartIsActive = False
         .Extend Character:=";"
         .EndKey
         .StartOf (wdLine)
        End With
       a = selection.MoveUntil(";", wdBackward)
       b = selection.MoveDown(wdLine, 2, wdMove)

    selection.StartOf (wdLine)
    selection.Find.Execute "*^13^13", , , True

    'some correction of range- remove last paragraph from selection
    ActiveDocument.Range(selection.Start, selection.End - 1).Select
    End If




End Function

Function GetParNum(r As Range) As Integer
'determines paragraph number
GetParNum = selection.Range.ListFormat.ListValue
End Function
Sub Test() 'testing function
CountWords

End Sub

Function SendDocToArray_FindWords(name As String) As Variant
'sends a document to an array split by newline
'the document that is send to the array is composed of the words that are
'being searched for.
Dim doc As Document
Set doc = Documents.Open(name)
Dim arr() As String
arr() = Split(doc.Content.Text, Chr(13))
Dim iCount As Integer
Dim targetRng As Range


For Each i In arr()

Dim r As Range
Dim j As Long
Set r = ActiveDocument.Content


With r.Find

'If I pass a variable to FindText it only finds the first instance of the word then
'prematurely exits loop or becomes an infinite loop
'strangely the function is only working when I hardcode the word such as
'FindText:= "International Business"
Do While .Execute(FindText:=i, Forward:=True, Wrap:=wdFindContinue) = True
    If r.Find.Found = True Then
    j = j + 1

    End If

Loop
End With
MsgBox "The Word" & i & " was found " & j & " times."



Next i
MsgBox ("Finished Selecting")
End Function

'testing count words function
Function CountWords(c As String)  'ByRef word As Variant
'counts number of occurences of words in document
Dim r As Range
Dim j As Long
Set r = ActiveDocument.Content

'ResetFRParameters r
With r.Find

'.Wrap = wdFindContinue
Do While .Execute(FindText:=i, Forward:=True) = True
If r.Find.Found = True Then
j = j + 1

End If

Loop
End With
MsgBox "Given word(s) was found " & j & " times."

End Function
'testing count words function
Sub FindText()
Dim MyAR() As String
Dim i As Long

i = 0

selection.HomeKey Unit:=wdStory
selection.Find.Text = "International Business"
' selection.Range.Text
Do While selection.Find.Execute = True
    ReDim Preserve MyAR(i)
    MyAR(i) = selection
    i = i + 1
Loop

If i = 0 Then
    MsgBox "No Matches Found"
    Exit Sub
End If

For i = LBound(MyAR) To UBound(MyAR)
    MsgBox ("# of International Business occurrences " & i)
Next i
End Sub

我使用了三个我试图正常工作的发现，但无论我如何使用它们，它们似乎都没有搜索整个文档。我开始怀疑我的文档格式是否应该归咎于此。我附上了术语列表的图像以及要搜索的文档。 This is the list of terms to search through This is the document to search through

我的最终问题是如何解决这个问题并在文档中找到给定搜索词的所有实例？到目前为止，它要么找到第一个实例并中断，要么成为无限循环。

对于可能正在寻找类似代码的其他人来说，这是最后的工作，虽然不是最漂亮的：（将其粘贴在这里，因为格式有点混乱，所以如果你使用它，你需要修复它们）

 Sub TraversePath()
 Dim fso As Object 'FileSystemObject
 Dim fldStart As Object 'Folder
 Dim fld As Object 'Folder
 Dim fl As Object 'File
 Dim Mask As String '.doc,.docx,.xlsx, etc

 Set fso = CreateObject("scripting.FileSystemObject") ' late binding
 'Set fso = New FileSystemObject 'or use early binding (also replace Object 
 types)

Set fldStart = fso.GetFolder("D:\school\documents\MGT450\Test_Bank\TB - 
test\") ' Base Directory

Mask = "*.doc"

ListFiles fldStart, Mask
'for each file in folder
'For Each fl In fldStart
'    ListFiles fld, Mask
MsgBox ("Fin.")
'Next
End Sub


Sub ListFiles(fld As Object, Mask As String)
Dim runTracker As Integer
runTracker = 0
Dim fl As Object 'File
x = NewDoc 'generate new processed study guide
Dim sCheckDoc As String
Dim docRef As Document
Dim vFile As String
Dim arr() As String
'list of words to look for
sCheckDoc = "D:\testlist.docx"
Set docRef = Documents.Open(sCheckDoc)

docRef.Activate
'send docref to array split by newline
arr() = Split(docRef.Content.Text, Chr(13))
'begin word array loop?
For Each fl In fld.Files
    runTracker = runTracker + 1
    If fl.name Like Mask Then
    '-----------------------------------------------------------------run 
 program code

        vFile = fl.name 'set vFile = current file name
        a = Documents.Open(fld.path & "\" & fl.name) 'open current search 
file
        Documents(vFile).Activate 'activate current search file

        For a = 0 To UBound(arr)

             'reset selection
             selection.HomeKey Unit:=wdStory, Extend:=wdMove
             'Inform progress
             StatusBar = "Running Find..."

             Dim docB As String
                 docB = Documents("Processed_StudyGuide.docx")
             Dim docA As String
                 docA = Documents(vFile)
                 Documents(docA).Activate

             b = DoFindReplace_Bkmk(arr(a))
             'print bookmarked values to new document
             StatusBar = "Printing targeted paragraphs..."
             PrintBookmarks (bookmarkName)
             If b <> 0 Then
                    'notify how many were inserted
                    MsgBox ("Complete, inserted: " & b & " bookmarks of " & 
arr(a))

             End If

        Next a

        MsgBox ("finished find in: " & vFile)
        Documents(vFile).Close (wdDoNotSaveChanges)
    '-----------------------------------------------------------------end 
code
    End If
Next
MsgBox ("Finished all documents")
End Sub

 Function SelectQuestion(Index As Long)
 'iniitial declaration
 Dim linecount As Integer
 Dim oPara As word.Paragraph
 'Dim oPara As selection
 Dim ListLevelNumber As Integer
 Dim holder As Long

'if list type is simple numbering
If selection.Range.ListFormat.ListType = wdListSimpleNumbering Or 
wdListBullet Or wdListMixedNumbering Then
    'Select Whole Question containing word
    With selection
     .StartIsActive = False
     .Extend Character:=";"
     .EndKey
     .StartOf (wdLine)
    End With
a = selection.MoveUntil(";", wdBackward)
b = selection.MoveDown(wdLine, 2, wdMove)

selection.StartOf (wdLine)
selection.Find.Execute "*^13^13", , , True

'some correction of range- remove last paragraph from selection
'ActiveDocument.Range(selection.start, selection.End - 1).Select
End If
End Function
Function GetParNum(r As Range) As Integer
'determines paragraph number
GetParNum = selection.Range.ListFormat.ListValue
End Function
Function NewDoc() As String
'Generate new document and save
a = Documents.Add(, , , True)
ActiveDocument.Content.Delete
ActiveDocument.SaveAs2 ("D:\Processed_StudyGuide")
End Function
Public Function GetName(num As Integer) As String
'names each bookmark
Dim t As String
Dim nameArr() As Variant
nameArr = Array("a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", 
"m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z", "aa", 
"bb", "cc", "dd", "ee", "ff", "gg", "hh", "ii", "jj", "kk", "ll", "mm", 
"nn", "oo", "pp", "qq", "rr", "ss", "tt", "uu", "vv", "ww", "xx", "yy", 
"zz", "aaa", "bbb", "ccc", "ddd", "eee", "fff", "ggg", "hhh", "iii", "jjj", 
"kkk", "lll", "mmm", "nnn", "ooo", "ppp", "qqq", "rrr", "sss", "ttt", "uuu", 
"vvv", "www", "xxx", "yyy", "zzz", "aaaa", "bbbb", "cccc", "dddd", "eeee", 
"ffff", "gggg", "hhhh", "iiii", "jjjj", "kkkk", "llll", "mmmm", "nnnn", 
"oooo", "pppp", "qqqq", "rrrr", "ssss", "tttt", "uuuu", "vvvv", "wwww", 
"xxxx", "yyyy", "zzzz", "aaaaa", "bbbbb", "ccccc", "ddddd")

t = nameArr(num)
GetName = t
End Function

Function PrintBookmarks(name As String) 'Add each selection to collection
'Declarations
selection.Collapse
Dim n As Integer
Dim docB As String
docB = Documents("Processed_StudyGuide.docx")
Dim docA As String
docA = ActiveDocument.name
Dim x As Integer
x = ActiveDocument.Bookmarks.Count
Dim a As String


For Each bkmark In Documents(docA).Bookmarks
'If # of bookmarks is greater than 0 select the one at x
If x > 0 Then
    With ActiveDocument.Bookmarks(x)
        BkMkName = .name
        .Select
    End With
End If
'selection.Bookmarks(a).Select
SelectQuestion (GetParNum(selection.Range))
selection.Copy
selection.Collapse (wdCollapseEnd)
Documents("Processed_StudyGuide.docx").Activate
selection.MoveEnd
selection.Paste

'reactivate last document
Documents(docA).Activate
x = x - 1
Next

'runs bookmark removal
removebookmarks (docA)
Documents(docB).Activate 'activate processed study guide
'    If ActiveDocument.Bookmarks.Count > 0 Then
'    FixRepeatedQuestions
'    End If
removebookmarks (docB)
ActiveDocument.Save
Documents(docA).Activate
End Function

Sub removebookmarks(name As String)
'removes bookmarks from documents
Dim bkm As Bookmark
For Each bkm In ActiveDocument.Bookmarks
bkm.Delete
Next bkm
End Sub
Function DoFindReplace_Bkmk(ByRef FindText As Variant, Optional ReplaceText 
As String) As Integer
Dim i As Integer
i = 0
Dim bkmark As String


With selection.Find
'set Find Parameters
.ClearFormatting
.Replacement.ClearFormatting
.Text = FindText
'If replacement text is not supplied replace with targetword to find
If ReplaceText = "" Then
.Replacement.Text = FindText
Else
.Replacement.Text = ReplaceText
End If
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
Do While .Execute
    'Keep going until nothing found
    .Execute Replace:=wdReplaceAll
    'keep track of how many are replaced

    'get bookmark name and add bookmark at location
    bookmarkName = GetName(i)
    ActiveDocument.Bookmarks.Add name:=bookmarkName, Range:=selection.Range
    i = i + 1 'below because array starts at 0
Loop
'Free up some memory
ActiveDocument.UndoClear
End With
'return # of find/replacements
DoFindReplace_Bkmk = i
End Function

Answer 1

For Each i In arr() 无法工作。

您的 Arr() 是一个字符串，并且 Each 枚举仅适用于对象。你必须使用

For i = 0 to Ubound(Arr)
Next i

这里是重复搜索的完整代码。请注意，TestCount 函数将其输出打印到 VBE 的立即窗口。如果您没有看到它，请按 Ctl+G 或从“查看”菜单中选择它，或将输出更改为 MsgBox。

Sub TestCount()
    ' testing procedure

    Dim MyPhrase As String

    MyPhrase = "International business"
    Debug.Print "My phrase was found " & CountWords(MyPhrase) & " times."
End Sub

Function CountWords(Phrase As String) As Integer
    ' 12 Apr 2017
    ' return the number of occurences of words in document

    Dim Fun As Integer                      ' Function return value
    Dim Rng As Range

    Set Rng = ActiveDocument.Content
    Do
        With Rng.Find
            .ClearFormatting
            .MatchCase = False
            .Text = Phrase
            .Execute
            If Not .Found Then Exit Do

            Fun = Fun + 1
        End With
    Loop
    CountWords = Fun
End Function

为了您的理解：-

1. Find 始终在您设置的范围的开头开始搜索。在程序开始时，范围被定义为ActiveDocument.Content。
2. 找到匹配项后，范围将重置为仅包含找到的短语，这意味着 Rng 与以前不同。
3. 现在循环使用更改后的 Rng 对象重复搜索，再次从该范围的开头开始到文档结尾。
4. 如果找不到更多匹配项，则退出循环。重要的是，不要 Wrap，因为该属性会指示 Find 在文档结尾未找到匹配项时继续在文档开头查找匹配项。

在这两者之间，在您现在看到Fun = Fun + 1 的地方，您可以执行您喜欢的任何代码 - 可能会在那里调用一个 sub 进行重大更改，甚至将部分文档复制到另一个文档。重要的是，在您完成所有工作后，Rng 指针仍然保留您要继续搜索的文档部分。

希望这会加快你的步伐。