问题
My question pertains to the Do While loop in my code, but I posted the whole thing to show you what I'm doing. This code will compare two documents. The object is to have blue text in a revision document added into the sentences of the original document and have that become a new third document. The functionality I am having trouble accomplishing is adding multiple words within a sentence. Right now I can add a word anywhere in a sentence as long as it is the only instance of blue text within that sentence. The program finds blue text and selects the entire sentence of that particular blue word. This is the only way I have thought how to reference where to add the new text to the third document. The blue text is removed from the sentence and that sentence is taken and found in the original document that has been copied. The blue text is then added back and saved to the new document. Here is a rundown of why one blue word per sentence will work and not two or more:
Does not work:
Original Document: "This String Is."
Revision Document: "This New String Is New."
The first blue word is found and taken out to compare the string to the original document but.....
"This String Is New" does not match with "This String Is"
This works though with just one blue word per sentence:
Original Document: "This String Is."
Revision Document: "This String Is New."
"New" is removed "This String Is." = "This String Is."
The sentence is found in the original document and the blue word is added to the copied original document and is saved. The program then moves onto the next blue word and repeats the process till no more blue text is found. However, without removing all instances of blue text within a sentence at once, there will not be a match in the orignal document. That is what I need help accomplishing, probably with an array.
Sub ArrayTest()
MsgBox "Welcome to the word document automatic modifier", vbInformation + vbOKOnly
MsgBox "Please open the revision file", vbInformation + vbOKOnly
Dim strfilename1 As String
Dim fd1 As Office.FileDialog
''''''Browsing/Opening the change request'''''''
Set fd1 = Application.FileDialog(msoFileDialogFilePicker)
With fd1
.AllowMultiSelect = False
.Title = "Open the modified word document."
.Filters.Clear
.Filters.Add "Word 2010", "*.docx"
.Filters.Add "All Files", "*.*"
If .Show = True Then
strfilename1 = .SelectedItems(1) 'replace txtFileName with your textbox
Else
Exit Sub
End If
End With
''''''''''' Browsing/Opening the original Design Manual'''''''''''''''''''''''''''
MsgBox "Open the orginal document", vbInformation + vbOKOnly
Dim strfilename2 As String
Dim fd2 As Office.FileDialog
Set fd2 = Application.FileDialog(msoFileDialogFilePicker)
With fd2
.AllowMultiSelect = False
.Title = "Please select the original file."
.Filters.Clear
.Filters.Add "Word 2010", "*.docx"
.Filters.Add "All Files", "*.*"
If .Show = True Then
strfilename2 = .SelectedItems(1) 'replace txtFileName with your textbox
Else
Exit Sub
End If
End With
MsgBox "Please enter the file name with which you want to store the new updated file", vbInformation + vbOKOnly
''''''''''''''''''Asking user to input name to the new revised document'''''''''''''''''''''''''''''''''''''
Dim strfilename3 As String
Dim fd3 As Office.FileDialog
Set fd3 = Application.FileDialog(msoFileDialogSaveAs)
With fd3
.AllowMultiSelect = False
.Title = "Please select the name to be given to the new file."
If .Show = True Then
strfilename3 = .SelectedItems(1) 'replace txtFileName with your textbox
Else
Exit Sub
End If
End With
Dim strg1 As String
Dim strg2 As String
Dim strg3 As String
Dim count As Integer
Dim strgArray()
FileCopy strfilename2, strfilename3
Set objWordChange = CreateObject("Word.Application")
Set objWordorig = CreateObject("Word.Application")
objWordChange.Visible = False
objWordorig.Visible = False
Set objDocChange = objWordChange.Documents.Open(strfilename1)
Set objSelectionChange = objWordChange.Selection
Set objDocOrig = objWordorig.Documents.Open(strfilename3)
Set objSelectionOrig = objWordorig.Selection
count = 0
objSelectionChange.Find.Forward = True
objSelectionChange.Find.Format = True
objSelectionChange.Find.Font.Color = wdColorBlue
Do While True
objSelectionChange.Find.Execute
If objSelectionChange.Find.Found Then
strg2 = objSelectionChange.Sentences(1).Text
count = count + 1
ReDim strgArray(count)
strgArray(count) = objSelectionChange.Text
MsgBox strgArray(count) & " Located In Array Index # " & count
MsgBox strg2
strg3 = Replace(strg2, strgArray(count), "")
strg3 = Replace(strg3, " ", " ")
strg3 = Mid(strg3, 1, Len(strg3) - 2)
strg4 = strg3
MsgBox strg4
Set objRangeOrig = objDocOrig.Content
'''''Search the string in the original manual'''''
With objRangeOrig.Find
.MatchWholeWord = False
.MatchCase = False
.MatchPhrase = True
.IgnoreSpace = True
.IgnorePunct = True
.Wrap = wdFindContinue
.Text = strg4
.Replacement.Text = Left(strg2, Len(strg2) - 2)
.Execute Replace:=wdReplaceOne
objDocOrig.Save
End With
Else
Exit Do
End If
Loop
objDocChange.Close
objDocOrig.Save
objDocOrig.Close
objWordChange.Quit
objWordorig.Quit
End Sub
Edit: This is the newer code as suggested by Dick, however it is still not completely working.
Sub WordReplaceSentence()
MsgBox "Welcome to the word document automatic modifier", vbInformation + vbOKOnly
MsgBox "Please open the revision file", vbInformation + vbOKOnly
Dim strfilename1 As String
Dim fd1 As Office.FileDialog
''''''Browsing/Opening the change request'''''''
Set fd1 = Application.FileDialog(msoFileDialogFilePicker)
With fd1
.AllowMultiSelect = False
.Title = "Open the modified word document."
.Filters.Clear
.Filters.Add "Word 2010", "*.docx"
.Filters.Add "All Files", "*.*"
If .Show = True Then
strfilename1 = .SelectedItems(1) 'replace txtFileName with your textbox
Else
Exit Sub
End If
End With
''''''''''' Browsing/Opening the original Design Manual'''''''''''''''''''''''''''
MsgBox "Open the orginal document", vbInformation + vbOKOnly
Dim strfilename2 As String
Dim fd2 As Office.FileDialog
Set fd2 = Application.FileDialog(msoFileDialogFilePicker)
With fd2
.AllowMultiSelect = False
.Title = "Please select the original file."
.Filters.Clear
.Filters.Add "Word 2010", "*.docx"
.Filters.Add "All Files", "*.*"
If .Show = True Then
strfilename2 = .SelectedItems(1) 'replace txtFileName with your textbox
Else
Exit Sub
End If
End With
MsgBox "Please enter the file name with which you want to store the new updated file", vbInformation + vbOKOnly
''''''''''''''''''Asking user to input name to the new revised document'''''''''''''''''''''''''''''''''''''
Dim strfilename3 As String
Dim fd3 As Office.FileDialog
Set fd3 = Application.FileDialog(msoFileDialogSaveAs)
With fd3
.AllowMultiSelect = False
.Title = "Please select the name to be given to the new file."
If .Show = True Then
strfilename3 = .SelectedItems(1) 'replace txtFileName with your textbox
Else
Exit Sub
End If
End With
FileCopy strfilename2, strfilename3
Set objWordChange = CreateObject("Word.Application")
Set objWordorig = CreateObject("Word.Application")
objWordChange.Visible = False
objWordorig.Visible = False
Set objDocChange = objWordChange.Documents.Open(strfilename1)
Set objSelectionChange = objWordChange.Selection
Set objDocOrig = objWordorig.Documents.Open(strfilename3)
Set objSelectionOrig = objWordorig.Selection
Dim rSearch As Range
Dim dict As Scripting.Dictionary
Dim i As Long
'Set up the documents - you already have this part
'We'll store the sentences here
Set dict = New Scripting.Dictionary
Set rSearch = objDocChange.Range
With rSearch
.Find.Forward = True
.Find.Format = True
.Find.Font.Color = wdColorBlue
.Find.Execute
Do While .Find.Found
Dim strg1
Dim strg2
strg1 = rSearch.Sentences(1).Text
MsgBox strg1
'key = revised sentence, item = original sentence
'if the revised sentence already exists in the dictionary, replace the found word in the entry
If dict.Exists(.Sentences(1).Text) Then
dict.Item(.Sentences(1).Text) = Replace$(Replace$(dict.Item(.Sentences(1).Text), .Text, vbNullString), Space(2), Space(1))
Else
'if the revised sentence isn't in the dict, then this is the first found word, so add it and replace the word
dict.Add .Sentences(1).Text, Replace$(Replace$(.Sentences(1).Text, .Text, vbNullString), Space(2), Space(1))
End If
.Find.Execute
Loop
End With
'Loop through all the dictionary entries and find the origial (item) and replace With
'the revised (key)
For i = 1 To dict.Count
Set rSearch = objDocOrig.Range
With rSearch.Find
.MatchWholeWord = False
.MatchCase = False
.MatchPhrase = True
.IgnoreSpace = True
.IgnorePunct = True
.Wrap = wdFindContinue
.Text = dict.Items(i - 1)
.Replacement.Text = dict.Keys(i - 1)
.Execute Replace:=wdReplaceOne
End With
Next i
objDocChange.Close
objDocOrig.Save
objDocOrig.Close
objWordChange.Quit
objWordorig.Quit
End Sub
回答1:
This uses a Scripting.Dictionary - set a reference using Tools - References to Microsoft Scripting Runtime.
It saves the sentence of each found entry as an entry to the dictionary. It only saves each sentence once. When it finds the second word, it replaces that word within what's already in the dictionary.
Sub MergeRevision()
Dim dcOrig As Document
Dim dcRev As Document
Dim dcNew As Document
Dim rSearch As Range
Dim dict As Scripting.Dictionary
Dim i As Long
'Set up the documents - you already have this part
Set dcOrig = Documents("Document1.docm")
Set dcRev = Documents("Document2.docx")
Set dcNew = Documents("Document3.docx")
dcOrig.Content.Copy
dcNew.Content.Paste
'We'll store the sentences here
Set dict = New Scripting.Dictionary
Set rSearch = dcRev.Range
With rSearch
.Find.Forward = True
.Find.Format = True
.Find.Font.Color = wdColorBlue
.Find.Execute
Do While .Find.Found
'key = revised sentence, item = original sentence
'if the revised sentence already exists in the dictionary, replace the found word in the entry
If dict.Exists(.Sentences(1).Text) Then
dict.Item(.Sentences(1).Text) = Replace$(Replace$(dict.Item(.Sentences(1).Text), .Text, vbNullString), Space(2), Space(1))
Else
'if the revised sentence isn't in the dict, then this is the first found word, so add it and replace the word
dict.Add .Sentences(1).Text, Replace$(Replace$(.Sentences(1).Text, .Text, vbNullString), Space(2), Space(1))
End If
.Find.Execute
Loop
End With
'Loop through all the dictionary entries and find the origial (item) and replace With
'the revised (key)
For i = 1 To dict.Count
Set rSearch = dcNew.Range
With rSearch.Find
.MatchWholeWord = False
.MatchCase = False
.MatchPhrase = True
.IgnoreSpace = True
.IgnorePunct = True
.Wrap = wdFindContinue
.Text = dict.Items(i - 1)
.Replacement.Text = dict.Keys(i - 1)
.Execute Replace:=wdReplaceOne
End With
Next i
End Sub
回答2:
Change your .Execute line to
Debug.Assert .Execute(Replace:=wdReplaceOne)
Execute returns False if it's unsuccessful and Debug.Assert stops the code when it's False. When it stops, go to the immediate window and type the debug.print (?) statements below (the answers I got are shown)
?.Text
The word Automation tool, will hopefully work .
?.Replacement.Text
The word Automation cool tool, will hopefully work now.
?rsearch.Text
This is a test. The word Automation tool, will hopefully work. This is not a test. Need a new sentence here now for the word Automation tool, hopefully this works.
The problem is that it can't find .Text because of the <space><period> at the end. We're deleting double spaces, but that doesn't work when the blue text is at the end of the sentence. You need to replace SpaceSpace, SpacePeriod, and SpaceComma, at least. Who knows what other strange punctuation you might encounter.
Once you get things working, you can get rid of the Debug.Assert. But you may want to throw an error when .Execute returns False so the user is aware it didn't copy correctly.
The reason I was getting those "processing" errors was because I was using FileCopy on a macro-enabled document and copying with a .docx extension. So my bad.
来源：https://stackoverflow.com/questions/32619642/adding-multiple-words-to-a-word-document-in-a-sentence-using-an-array-with-vba