How to avoid Word Macro running too slow and sometimes causing APP collapse?-CodePudding

Every time I ran this macro for a word document with 100 to 150 pages, I need to wait for minutes and sometimes the screen will turn into black. Since the .txt file contains 769 words, how to speed up the processing time?

Sub proofreading()

ActiveDocument.TrackRevisions = True
Dim arrStr() As String, InputStr As String
Fn = FreeFile
Open "G:\Proofreaders\PR.txt" For Input As #Fn
Application.ScreenUpdating = False

While Not EOF(Fn)
    Line Input #Fn, InputStr
    If Len(InputStr) > 0 And Mid(InputStr, 1, 1) <> "'" Then
        arrStr = Split(InputStr, ",")

        Call ReplaceText(arrStr(0), arrStr(1))
    End If
Wend
Application.ScreenUpdating = True
Close #Fn
ActiveDocument.TrackRevisions = False
MsgBox ("Completed")

End Sub
Function ReplaceText(Src As String, Rpl As String)
Selection.HomeKey Unit:=wdStory, Extend:=wdMove
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
    .Text = Src
    .Replacement.Text = Rpl
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = True
    .MatchByte = True
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = False
    .MatchFuzzy = False
    .Execute Replace:=wdReplaceAll
End With
End Function

Hello all, I have a macro for replacing text according to a .txt file in Microsoft Word. This macro is for replacing texts in a Word Document with 100 to 150 pages. Since it contains 769 words, the screen will temporarily turned into black when the macro is processing. Even though it can ran successfully every time after 45 seconds to 1 min, I still want to improve it to avoid the blackscreen, no-response, and the speed of the Macro. Does anyone have any methods enhancing the processing speed of the following macro? Thank you!

CodePudding user response：

You can avoid selecting the text every time (which is very "expensiv") by using ThisDocument.Content:

Function ReplaceText(Src As String, Rpl As String)

With ThisDocument.Content.Find
    .ClearFormatting
    .Replacement.ClearFormatting

    .Text = Src
    .Replacement.Text = Rpl
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = True
    .MatchByte = True
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = False
    .MatchFuzzy = False
    .Execute Replace:=wdReplaceAll
End With
End Function

Sometimes it could help to reset the undo-stack regularly - if you have a lot of changes: ThisDocument.UndoClear

CodePudding user response：

Your macro is incredibly inefficient as a result of using Selection. Re-specifying the static variables on each loop in also inefficient. Try:

Sub FndRepDemo()
Application.ScreenUpdating = False
Dim DocSrc As Document, FRList As String, i As Long
Set DocSrc = Documents.Open("G:\Proofreaders\PR.txt", ReadOnly:=True, AddToRecentFiles:=False)
FRList = DocSrc.Range.Text: DocSrc.Close False: Set DocSrc = Nothing
With ActiveDocument.Range.Find
  .Forward = True
  .Format = False
  .MatchCase = False
  .MatchWholeWord = True
  .MatchByte = True
  .MatchAllWordForms = False
  .MatchSoundsLike = False
  .MatchWildcards = False
  .MatchFuzzy = False
  .Wrap = wdFindContinue
  For i = 0 To UBound(Split(FRList, vbCr)) - 1
    .Text = Split(Split(FRList, vbCr)(i), ",")(0)
    .Replacement.Text = Split(Split(FRList, vbCr)(i), ",")(1)
    .Execute Replace:=wdReplaceAll
  Next
End With
Application.ScreenUpdating = True
End Sub