0
该程序应该循环遍历一个目录，从另一个单词文档中的列表中查找每个出现的单词，并将选择范围扩大到整个问题。这个程序应该允许您根据高度相关的关键术语列表从测试银行编制测试问题列表。最终，一旦选择了所有相关问题，它们将被复制到一个新文档中。为什么.Find函数在此代码中无法正常工作？
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
您指出的更改。仍然只发现第一个实例，然后提前中断FindText（）中的循环。 @Variatus – Wes
谢谢你帮了很多@Variatus – Wes