使用带有VBA的数组将多个单词添加到句子中的单词文档

Question

我的问题与我的代码中的 Do While 循环有关，但我发布了整个内容以向您展示我在做什么。此代码将比较两个文档。目的是将修订文档中的蓝色文本添加到原始文档的句子中，并使其成为新的第三个文档。我无法完成的功能是在一个句子中添加多个单词。现在我可以在句子的任何地方添加一个单词，只要它是该句子中唯一的蓝色文本实例。该程序找到蓝色文本并选择该特定蓝色单词的整个句子。这是我想到如何引用将新文本添加到第三个文档的唯一方法。从句子中删除蓝色文本，并在已复制的原始文档中找到该句子。然后将蓝色文本添加回并保存到新文档中。以下是为什么每个句子一个蓝色单词会起作用而不是两个或更多的原因的简要说明：

不起作用：
原始文档：“这个字符串是。”
修订文档：“这个 New 字符串是 New.”
找到并取出第一个蓝色单词，将字符串与原始文档进行比较，但是.....
“This String Is New”与“This String Is”不匹配

虽然每个句子只有一个蓝色单词，但这是有效的：
原始文档：“这个字符串是。”
修订文档：“这个字符串是新的。”
“新”被删除 “这个字符串是”。 = "这个字符串是。"

在原文档中找到句子，将蓝字添加到复制的原文档中并保存。然后程序移动到下一个蓝色单词并重复该过程，直到找不到更多蓝色文本。 但是，如果不一次删除句子中的所有蓝色文本实例，则原始文档中不会有匹配项。这就是我需要帮助完成的事情，可能需要一个数组。

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

编辑：这是 Dick 建议的较新代码，但仍不能完全正常工作。

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

Answer 1

这使用 Scripting.Dictionary - 使用工具设置引用 - 对 Microsoft Scripting Runtime 的引用。

它将每个找到的条目的句子保存为字典的条目。它只保存每个句子一次。当它找到第二个单词时，它会替换字典中已有的单词。

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

Answer 2

将您的 .Execute 行更改为

Debug.Assert .Execute(Replace:=wdReplaceOne)

如果不成功，Execute 会返回 False，而 Debug.Assert 会在它为 False 时停止代码。当它停止时，转到即时窗口并在下面键入 debug.print (?) 语句（显示我得到的答案）

?.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.

问题是它找不到.Text，因为末尾有<space><period>。我们正在删除双空格，但当蓝色文本位于句子末尾时，这不起作用。您至少需要替换 SpaceSpace、SpacePeriod 和 SpaceComma。谁知道你还会遇到什么奇怪的标点符号。

一旦你开始工作，你就可以摆脱 Debug.Assert。但是您可能希望在 .Execute 返回 False 时抛出错误，以便用户知道它没有正确复制。

我收到这些“处理”错误的原因是我在启用宏的文档上使用 FileCopy 并使用 .docx 扩展名进行复制。所以我的坏。