excelvbams-wordspelling

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