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