How to improve slow macro?

I need to use 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 1 page of the Word Document.

Can I use .txt to replace the excel 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