使用帶有VBA的數組將多個單詞添加到句子中的單詞文檔中

Question

我的問題與代碼中的Do While循環有關，但我發布了整個過程以向您展示我在做什么。 此代碼將比較兩個文檔。 目的是將修訂文檔中的藍色文本添加到原始文檔的句子中，並使之成為新的第三文檔。 我無法完成的功能是在一個句子中添加多個單詞。 現在，我可以在一個句子的任何地方添加一個單詞，只要它是該句子中藍色文本的唯一實例即可。 程序將查找藍色文本並選擇該特定藍色單詞的整個句子。 這是我想到如何引用將新文本添加到第三文檔的唯一方法。 藍色文本從句子中刪除，該句子被采用並在已復制的原始文檔中找到。 然后將藍色文本添加回去並保存到新文檔中。 以下是每個句子中一個藍色單詞而不是兩個或多個單詞起作用的原因的摘要：

不起作用：
原始文檔：“此字符串是。”
修訂文檔：“此新字符串是新字符串。 ”
找到第一個藍色單詞，然后將其與原始文檔進行比較，但是.....
“此字符串是新的”與“此字符串是”不匹配

盡管每個句子只有一個藍色單詞，但這是可行的：
原始文檔：“此字符串是。”
修訂文檔：“此字符串是新字符串。”
“新建”已刪除“此字符串為”。 =“此字符串為。”

在原始文檔中找到該句子，然后將藍色單詞添加到復制的原始文檔中並保存。 然后，程序移至下一個藍色單詞並重復該過程，直到找不到更多藍色文本為止。 但是 ，如果不立即刪除一個句子中所有藍色文本的實例，原始文檔中將不會有匹配項。 那是我需要幫助完成的工作，可能需要使用數組。

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；如果為False，則Debug.Assert停止代碼。 當它停止時，轉到立即窗口並在下面鍵入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.

問題在於由於末尾的<space><period> ，它無法找到.Text 。 我們正在刪除雙精度空格，但是當藍色文本位於句子結尾時，該功能將無效。 您至少需要替換SpaceSpace，SpacePeriod和SpaceComma。 誰知道您可能還會遇到其他奇怪的標點符號。

一旦一切正常，就可以擺脫Debug.Assert。 但是，當.Execute返回False時，您可能想拋出一個錯誤，以便用戶知道它沒有正確復制。

我得到那些“處理”錯誤的原因是因為我在啟用宏的文檔上使用FileCopy並以.docx擴展名進行復制。 所以我不好。