How to prevent word from crashing when using batch find and replace macro?

问题

I am using this code which is a batch find and replace macro. It finds and replaces the words in the document by reading the replacement words from another document (text.docx). This works absolutely fine when there are a handful of changes (i.e. less than 1 page). However, I hope to use this macro on documents that are 10-20 pages. When I use it, the word document just immediately crashes (starts not responding) and has to be forced to quit.

Does anyone have any tips on what can be done to prevent it from crashing? How can I modify the code to batch edit thousands of words? Code is below.

Thanks in advance!

    Sub ReplaceFromTableList()
Dim oChanges As Document, oDoc As Document
Dim oTable As Table
Dim oRng As Range
Dim rFindText As Range, rReplacement As Range
Dim i As Long
Dim y As Integer
Dim sFname As String
Dim sAsk As String
    sFname = "/Users/user/Desktop/test.docx"
    Set oDoc = ActiveDocument
    Set oChanges = Documents.Open(FileName:=sFname, Visible:=False)
    Set oTable = oChanges.Tables(1)
    y = 0
    For i = 1 To oTable.Rows.Count
        Set oRng = oDoc.Range
        Set rFindText = oTable.Cell(i, 1).Range
        rFindText.End = rFindText.End - 1
        Set rReplacement = oTable.Cell(i, 2).Range
        rReplacement.End = rReplacement.End - 1
        With oRng.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            Do While .Execute(findText:=rFindText, _
                              MatchWholeWord:=True, _
                              MatchWildcards:=False, _
                              Forward:=True, _
                              Wrap:=wdFindStop) = True
                oRng.Select

                    oRng.FormattedText = rReplacement.FormattedText
                    y = y + 1
            Loop
        End With
    Next i
    oChanges.Close wdDoNotSaveChanges
    MsgBox (y & " errors fixed")
End Sub

回答1:

Your use of the FormattedText method to reproduce the formatting necessitates a time-consuming loop for each expression. The more the find expression occurs in the target document, the longer the process will take. Your unnecessary use of oRng.Select (which you don't then do anything with) makes it even slower - especially since you don't disable ScreenUpdating. The following macro avoids the need for the FormattedText looping:

Sub BulkFindReplace()
Application.ScreenUpdating = False
Dim ThisDoc As Document, FRDoc As Document, Rng As Range, i As Long, j As Long, StrRep As String, StrCount As String
Set ThisDoc = ActiveDocument
Set FRDoc = Documents.Open("C:\Users\" & Environ("Username") & "\Downloads\FindReplaceTable.docx", _
  ReadOnly:=True, AddToRecentFiles:=False, Visible:=False)
With ThisDoc.Range.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Format = False
  .Forward = True
  .Wrap = wdFindContinue
   'Process each word from the F/R Table
  For i = 1 To FRDoc.Tables(1).Rows.Count
    Set Rng = FRDoc.Tables(1).Rows(i).Cells(1).Range
    Rng.End = Rng.End - 1
    .Text = Rng
    StrCount = StrCount & vbCr & Rng.Text & ":" & vbTab & _
      (Len(ThisDoc.Range.Text) - Len(Replace(ThisDoc.Range, Rng.Text, ""))) / Len(Rng.Text)
    Set Rng = FRDoc.Tables(1).Rows(i).Cells(2).Range
    Rng.End = Rng.End - 1
    With Rng
      If Len(.Text) > 0 Then
        .Copy
        StrRep = "^c"
      Else
        StrRep = ""
      End If
    End With
    .Replacement.Text = StrRep
    .Execute Replace:=wdReplaceAll
    If i Mod 20 = 0 Then DoEvents
  Next
End With
FRDoc.Close False
MsgBox "The following strings were replaced:" & StrCount
Set Rng = Nothing: Set FRDoc = Nothing: Set ThisDoc = Nothing
Application.ScreenUpdating = True
End Sub

回答2:

Does this help you?

Sub FindReplaceAll()

    Dim MyDialog As FileDialog, GetStr(1 To 100) As String 
'100 files is the maximum applying this code
    On Error Resume Next
Set MyDialog = Application.FileDialog(msoFileDialogFilePicker)
With MyDialog
        .Filters.Clear
        .AllowMultiSelect = True
        i = 1
        If .Show = -1 Then
            For Each stiSelectedItem In .SelectedItems
                GetStr(i) = stiSelectedItem
                i = i + 1
            Next
            i = i - 1
        End If
        Application.ScreenUpdating = False
        For j = 1 To i Step 1
Set Doc = Documents.Open(FileName:=GetStr(j), Visible:=True)
Windows(GetStr(j)).Activate
            Selection.Find.ClearFormatting
            Selection.Find.Replacement.ClearFormatting
            With Selection.Find
                .Text = "Marriott International" 'Find What
                .Replacement.Text = "Marriott" 'Replace With
                .Forward = True
                .Wrap = wdFindAsk
                .Format = False
                .MatchCase = False
                .MatchWholeWord = False
                .MatchByte = True
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
            End With
            Selection.Find.Execute Replace:=wdReplaceAll
Application.Run macroname:="NEWMACROS"
ActiveDocument.Save
            ActiveWindow.Close
        Next
        Application.ScreenUpdating = True
    End With
    MsgBox "operation end, please view", vbInformation

End Sub

' The idea comes from here. ' https://www.extendoffice.com/documents/word/1002-word-replace-multiple-files.html

来源：https://stackoverflow.com/questions/61845903/how-to-prevent-word-from-crashing-when-using-batch-find-and-replace-macro