How can I improve a slow macro?

I need to use a Word macro for automatically proofreading the documents. I have an Excel file, filled in with all the wrong spelling words, and after I installed the macro to Microsoft Word, it took several minutes to finish the spelling checking for just one page of the Word document.

Can I use .txt file to replace the Excel sheet in order to make it faster? Or what should I improve? Below please find the code for the macro:

Attribute VB_Name = "PR"

Option Explicit

Sub PR()
    Dim Path As String
    Dim objExcel As Object
    Dim iCount As Integer
    Dim VChar As String
    Dim OChar As String

    Options.AutoFormatAsYouTypeReplaceQuotes = True

    Path = "D:\Macro\rplPR.xlsx"

    'Highlight variant characters
    With ActiveDocument
        .TrackRevisions = False
        .ShowRevisions = False
    End With

    Set objExcel = CreateObject("Excel.Application")
    objExcel.Workbooks.Open Path

    For iCount = 2 To 2500

        Selection.HomeKey Unit:=wdStory
        VChar = objExcel.ActiveWorkbook.Sheets(1).Cells(iCount, 1)

        If Len(VChar) = 0 Then Exit For

        Selection.HomeKey Unit:=wdStory, Extend:=wdMove

        With Selection.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Replacement.Highlight = True
            .Text = VChar
            .Replacement.Text = "^&"
            .Execute Replace:=wdReplaceAll
        End With
    Next

    objExcel.ActiveWorkbook.Close
    objExcel.Quit

End Sub

Solution

Try the following. Do note that there is necessarily some overhead involved in starting Excel (if not already running), as well as processing the workbook. Hence, even a single-page document will encounter the same overhead there as a 100-page document.

Sub BulkFindReplace()
Application.ScreenUpdating = False
Dim xlApp As Object, xlWkBk As Object, StrWkBkNm As String, StrWkSht As String
Dim iDataRow As Long, xlFList As String, xlRList As String, i As Long
StrWkBkNm = "D:\Macro\rplPR.xlsx": StrWkSht = "Sheet1"
'Start Excel
Set xlApp = CreateObject("Excel.Application")
If xlApp Is Nothing Then
  MsgBox "Can't start Excel.", vbExclamation
  Exit Sub
End If
On Error GoTo 0
With xlApp
  'Hide our Excel session
  .Visible = False
  ' The file is available, so open it.
  Set xlWkBk = .Workbooks.Open(StrWkBkNm, False, True)
  If xlWkBk Is Nothing Then
    MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation
    .Quit: Set xlApp = Nothing: Exit Sub
  End If
  ' Process the workbook.
  With xlWkBk
    With .Worksheets(StrWkSht)
      ' Find the last-used row in column A.
      iDataRow = .Cells(.Rows.Count, 1).End(-4162).Row ' -4162 = xlUp
      ' Capture the F/R data.
      For i = 1 To iDataRow
        ' Skip over empty fields to preserve the underlying cell contents.
        If Trim(.Range("A" & i)) <> vbNullString Then
          xlFList = xlFList & "|" & Trim(.Range("A" & i))
          xlRList = xlRList & "|" & Trim(.Range("B" & i))
        End If
      Next
    End With
  .Close False
  End With
  .Quit
End With
' Release Excel object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
'Exit if there are no data
If xlFList = "" Then Exit Sub
'Process each word from the F/R List
With ActiveDocument.Range.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .MatchWholeWord = True
  .MatchCase = False
  .Wrap = wdFindContinue
  For i = 1 To UBound(Split(xlFList, "|"))
    .Text = Split(xlFList, "|")(i)
    .Replacement.Text = Split(xlRList, "|")(i)
    .Execute Replace:=wdReplaceAll
  Next
End With
Application.ScreenUpdating = True
End Sub