使用使用VBA数组中添加多个单词到Word文档中的一个句子 [英] Adding multiple words to a word document in a sentence using an array with VBA
本文介绍了使用使用VBA数组中添加多个单词到Word文档中的一个句子的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！
问题描述
我的问题涉及到do while循环在我的code，但我张贴整个事情给你看我在做什么。这code将比较两个文件。目的是具有添加到原始文档的句子修订文档中蓝色文本和具有成为一个新的第三文档。我无法办成的功能是一个句子中添加多个单词。现在，我可以在任何地方在一个句子里只要加一个字，因为它是一个句子中的蓝色文本的唯一实例。该程序发现蓝色文本，并选择特定的蓝字的整个句子。这是我认为如何引用在哪里新的文本添加到第三个文档的唯一途径。蓝色的文字是从句子删除，那句话取，发现已经复制原始文档英寸然后，将蓝色文本添加回并保存到新文档。这是为什么每个句子一蓝字将工作一所破旧的，而不是两个或多个：
不起作用：
原文件：此字符串。
修订文件：这个新 string是新。
第一个蓝色字是发现和取出字符串比较原始文档，但.....
这个字符串是新的不匹配此字符串
这工作虽然每个句子只有一个蓝色字：
原文件：此字符串。
修订文件：此字符串新。
新被删除此字符串。 =此字符串。
这句话是在原始文档中发现和蓝色的字被添加到复制的原始文件，并保存。然后程序移动到下一个蓝色的字和耕种的更蓝文本中找到重复此过程。 然而，没有一个句子中取出蓝色文本的所有实例一次，但不会是一部开拓创新的文档中的比赛。这就是我需要帮助完成，可能与一个数组。
子ArrayTest中（） MSGBOX欢迎到word文档自动调节剂，vbInformation + vbOKOnly MsgBox请打开修订文件，vbInformation + vbOKOnly 昏暗strfilename1作为字符串
昏暗FD1作为Office.FileDialog ''''''浏览/打开变更请求''''''' 设置FD1 = Application.FileDialog（msoFileDialogFilePicker） 随着FD1 .AllowMultiSelect =假
.title伪=打开修改后的Word文档。
.Filters.Clear
.Filters.AddWord 2010中，* .DOCX
.Filters.Add所有文件，*。* 如果.Show = TRUE然后
strfilename1 = .SelectedItems（1）你的文本替换txtFileName
其他
退出小组
万一
结束与
'''''''''''浏览/打开原设计手册'''''''''''''''''''''''''''MSGBOX打开文件原单，vbInformation + vbOKOnly
昏暗strfilename2作为字符串 昏暗FD2由于Office.FileDialog 设置FD2 = Application.FileDialog（msoFileDialogFilePicker） 随着FD2 .AllowMultiSelect =假
.title伪=请选择原始文件。
.Filters.Clear
.Filters.AddWord 2010中，* .DOCX
.Filters.Add所有文件，*。* 如果.Show = TRUE然后
strfilename2 = .SelectedItems（1）你的文本替换txtFileName
其他
退出小组
万一
结束与
MsgBox请输入与您要存储新的更新文件的文件名，vbInformation + vbOKOnly
''''''''''''''''''询问用户输入名称到新修订的文件'''''''''''''''''''''' '''''''''''''''昏暗strfilename3作为字符串 昏暗FD3作为Office.FileDialog 设置FD3 = Application.FileDialog（msoFileDialogSaveAs） 随着FD3
.AllowMultiSelect =假
.title伪=请选择名称被赋予新的文件。
如果.Show = TRUE然后
strfilename3 = .SelectedItems（1）你的文本替换txtFileName
其他
退出小组
万一
结束与
昏暗strg1作为字符串
昏暗strg2作为字符串
昏暗strg3作为字符串
昏暗的计数作为整数
昏暗strgArray（）
FileCopy strfilename2，strfilename3设置objWordChange =的CreateObject（Word.Application）
设置objWordorig =的CreateObject（Word.Application）objWordChange.Visible =假
objWordorig.Visible =假设置objDocChange = objWordChange.Documents.Open（strfilename1）
设置objSelectionChange = objWordChange.Selection
设置objDocOrig = objWordorig.Documents.Open（strfilename3）
设置objSelectionOrig = objWordorig.Selection数= 0objSelectionChange.Find.Forward = TRUE
objSelectionChange.Find.Format = TRUE
objSelectionChange.Find.Font.Color = wdColorBlue做真时
objSelectionChange.Find.Execute
如果objSelectionChange.Find.Found然后
strg2 = objSelectionChange.Sentences（1）。文本
数=计+ 1
使用ReDim strgArray（计数）
strgArray（计数）= objSelectionChange.Text
MSGBOX strgArray（计数）及设在数组索引＃＆放大器;计数
MSGBOX strg2
strg3 =替换（strg2，strgArray（计数），）
strg3 =替换（strg3，，）
strg3 = MID（strg3，1，LEN（strg3） - 2）
strg4 = strg3
MSGBOX strg4 设置objRangeOrig = objDocOrig.Content
'''''的搜索在原有的手工字符串'''''
随着objRangeOrig.Find
.MatchWholeWord = FALSE
.MatchCase =假
.MatchPhrase = TRUE
.IgnoreSpace = TRUE
.IgnorePunct = TRUE
.Wrap = wdFindContinue
的.text = strg4
.Replacement.Text =左（strg2，莱恩（strg2） - 2）
.Execute替换：= wdReplaceOne
objDocOrig.Save
结束与
其他
退出待办事项
万一
循环
objDocChange.Close
objDocOrig.Save
objDocOrig.CloseobjWordChange.Quit
objWordorig.Quit结束小组
编辑：这是由迪克提出的新的code，但它仍然没有完全工作的
子WordReplaceSentence（）MSGBOX欢迎到word文档自动调节剂，vbInformation + vbOKOnlyMsgBox请打开修订文件，vbInformation + vbOKOnly 昏暗strfilename1作为字符串
昏暗FD1作为Office.FileDialog ''''''浏览/打开变更请求''''''' 设置FD1 = Application.FileDialog（msoFileDialogFilePicker） 随着FD1 .AllowMultiSelect =假
.title伪=打开修改后的Word文档。
.Filters.Clear
.Filters.AddWord 2010中，* .DOCX
.Filters.Add所有文件，*。* 如果.Show = TRUE然后
strfilename1 = .SelectedItems（1）你的文本替换txtFileName
其他
退出小组
万一
结束与
'''''''''''浏览/打开原设计手册'''''''''''''''''''''''''''MSGBOX打开文件原单，vbInformation + vbOKOnly
昏暗strfilename2作为字符串 昏暗FD2由于Office.FileDialog 设置FD2 = Application.FileDialog（msoFileDialogFilePicker） 随着FD2 .AllowMultiSelect =假
.title伪=请选择原始文件。
.Filters.Clear
.Filters.AddWord 2010中，* .DOCX
.Filters.Add所有文件，*。* 如果.Show = TRUE然后
strfilename2 = .SelectedItems（1）你的文本替换txtFileName
其他
退出小组
万一
结束与
MsgBox请输入与您要存储新的更新文件的文件名，vbInformation + vbOKOnly
''''''''''''''''''询问用户输入名称到新修订的文件'''''''''''''''''''''' ''''''''''''''' 昏暗strfilename3作为字符串 昏暗FD3作为Office.FileDialog 设置FD3 = Application.FileDialog（msoFileDialogSaveAs） 随着FD3
.AllowMultiSelect =假
.title伪=请选择名称被赋予新的文件。
如果.Show = TRUE然后
strfilename3 = .SelectedItems（1）你的文本替换txtFileName
其他
退出小组
万一
结束与 FileCopy strfilename2，strfilename3 设置objWordChange =的CreateObject（Word.Application）
设置objWordorig =的CreateObject（Word.Application） objWordChange.Visible =假
objWordorig.Visible =假 设置objDocChange = objWordChange.Documents.Open（strfilename1）
设置objSelectionChange = objWordChange.Selection
设置objDocOrig = objWordorig.Documents.Open（strfilename3）
设置objSelectionOrig = objWordorig.Selection 昏暗rSearch由于范围
昏暗的字典作为的Scripting.Dictionary
昏暗我只要 建立的文件 - 你已经有了这部分
我们将在这里存储的句子
设置字典=新的Scripting.Dictionary 设置rSearch = objDocChange.Range
随着rSearch
.Find.Forward = TRUE
.Find.Format = TRUE
.Find.Font.Color = wdColorBlue
.Find.Execute 做虽然.Find.Found
昏暗strg1
昏暗strg2
strg1 = rSearch.Sentences（1）。文本
MSGBOX strg1
'键=修订句项目=原句
如果修改后的句子在字典中已经存在，在入门替换找到的字
如果dict.Exists（.Sentences（1）。文本）然后
dict.Item（.Sentences（1）。文本）=替换$（替换$（dict.Item（.Sentences（1）。文本）。文本，vbNullString），空间（2），空间（1））
其他
如果修改后的句子是不是在字典，那么这是第一个被发现的话，那么添加和替换词
dict.Add .Sentences（1）。文本，替换$（更换$（句子（1）。文本，。文本，vbNullString），空间（2），空间（1））
万一 .Find.Execute
循环
结束与 在所有的字典条目环路和找到origial（项目），并取代
修订后的（键）
对于i = 1到dict.Count
设置rSearch = objDocOrig.Range
随着rSearch.Find
.MatchWholeWord = FALSE
.MatchCase =假
.MatchPhrase = TRUE
.IgnoreSpace = TRUE
.IgnorePunct = TRUE
.Wrap = wdFindContinue
的.text = dict.Items（I - 1）
.Replacement.Text = dict.Keys（I - 1）
.Execute替换：= wdReplaceOne
结束与
接下来，我objDocChange.Close
objDocOrig.Save
objDocOrig.CloseobjWordChange.Quit
objWordorig.Quit结束小组
解决方案
此使用的Scripting.Dictionary - 使用工具集的引用 - 引用Microsoft脚本运行时
它保存每个找到的条目作为一个入口到字典中的句子。它不仅节省了每个句子一次。当它发现的第二个字，它会替换内什么已经在字典这个词。
子MergeRevision（） 昏暗dcOrig作为文档
昏暗dcRev作为文档
昏暗dcNew作为文档
昏暗rSearch由于范围
昏暗的字典作为的Scripting.Dictionary
昏暗我只要 建立的文件 - 你已经有了这部分
设置dcOrig =文件（Document1.docm）
设置dcRev =文件（Document2.docx）
设置dcNew =文件（Document3.docx）
dcOrig.Content.Copy
dcNew.Content.Paste 我们将在这里存储的句子
设置字典=新的Scripting.Dictionary 设置rSearch = dcRev.Range
随着rSearch
.Find.Forward = TRUE
.Find.Format = TRUE
.Find.Font.Color = wdColorBlue
.Find.Execute 做虽然.Find.Found
'键=修订句项目=原句
如果修改后的句子在字典中已经存在，在入门替换找到的字
如果dict.Exists（.Sentences（1）。文本）然后
dict.Item（.Sentences（1）。文本）=替换$（替换$（dict.Item（.Sentences（1）。文本）。文本，vbNullString），空间（2），空间（1））
其他
如果修改后的句子是不是在字典，那么这是第一个被发现的话，那么添加和替换词
dict.Add .Sentences（1）。文本，替换$（更换$（句子（1）。文本，。文本，vbNullString），空间（2），空间（1））
万一 .Find.Execute
循环
结束与 在所有的字典条目环路和找到origial（项目），并取代
修订后的（键）
对于i = 1到dict.Count
设置rSearch = dcNew.Range
随着rSearch.Find
.MatchWholeWord = FALSE
.MatchCase =假
.MatchPhrase = TRUE
.IgnoreSpace = TRUE
.IgnorePunct = TRUE
.Wrap = wdFindContinue
的.text = dict.Items（I - 1）
.Replacement.Text = dict.Keys（I - 1）
.Execute替换：= wdReplaceOne
结束与
接下来，我结束小组
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
解决方案
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
这篇关于使用使用VBA数组中添加多个单词到Word文档中的一个句子的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
查看全文
