Find and Replace in Microsoft Word 2010

Question

I have a VBA macro for Microsoft Word that I am trying to improve.

The macro is typically used on a Word document of around 50,000 words which is divided into around 500 sections

The purpose of the macro is to highlight words/phrases in a Word document and insert a footnote for the first occurrence of that word/phrase in each section.

The operations undertaken by the macro are as follows:

it counts the number of sections in a document and the number of words in an Excel file (around 190 words or phrases in the Excel file)

It then finds in the first section of the Word document the first occurrence of the first word or phrase from an Excel file.

It then inserts a footnote for that word or phrase (the text of which is from another column in the Excel file)

It then changes the colour of all instances of that word or phrase in that section

It then repeats this operation for the next section until the end of the document.

It then goes back to the first section and repeats the process for the next word in the Excel list.

The problem is the find and replace operation takes forever to complete.

The Excel list is sorted in descending order, so that the largest phrase or word comes first.

I do this because some of the phrases are compounds of smaller words or phrases. The larger phrases are located and changed first so that the smaller elements of the phrases are not picked up incorrectly by the find and replace.

The document is in sections as I want to have the first instance of a word/phrase in each section to have a footnote, with the rest being highlighted by a change a colour.

The find and replace operation occurs 190,000 times (500 sections* 190 words* 2 operations per section), which means that it takes a couple of days to run on my computer.

I have played around with the ordering of the loops and am at a loss as to how reduce the time that this code takes to run whilst keeping the output which I want to achieve.

Can I please have some help/suggestions for a better way of undertake this operation?

Here is a copy of the code I am working with:

    Sub Test()
Word.Application.ScreenUpdating = False
Dim xlapp As Object
Dim xlbook As Object
Dim xlsheet As Object
Dim xlrange1 As Object
Dim xlrange2 As Object
Dim myarray As Variant
Dim Findarray As Variant
Dim Replarray As Variant
On Error Resume Next
Set xlapp = GetObject(, "Excel.Application")
If Err Then
 bstartApp = True
 Set xlapp = CreateObject("Excel.Application")
End If
On Error GoTo 0
With xlapp
 Set xlbook = .Workbooks.Open("C:\Users\Documents\test.xlsx")
 Set xlsheet = xlbook.Worksheets(2)
 With xlsheet
 Set xlrange1 = .Range("A1", .Range("A1").End(4))
 Set xlrange2 = .Range("B1", .Range("B1").End(4))
 Findarray = xlrange1.Value
 Replarray = xlrange2.Value
 End With
End With
If bstartApp = True Then
 xlapp.Quit
End If
Set xlapp = Nothing
Set xlbook = Nothing
Set xlsheet = Nothing
Set xlrange1 = Nothing
Set xlrange2 = Nothing
iSectCount = ActiveDocument.Sections.Count
For i = 2 To UBound(Findarray)
For x = 1 To iSectCount
ActiveDocument.Sections(x).Range.Select
Selection.Find.ClearFormatting
 Selection.Find.Font.Color = -587137025
 Selection.Find.Replacement.ClearFormatting
 With Selection.Find
 .Text = Findarray(i, 1)
 .Forward = True
 .Format = True
 .MatchWholeWord = True
 End With
 If Selection.Find.Execute Then
 ActiveDocument.Footnotes.Add Range:=Selection.Range, Text:=Replarray(i, 1)
 End If
 ActiveDocument.Sections(x).Range.Select
Selection.Find.ClearFormatting
 Selection.Find.Font.Color = -587137025
 Selection.Find.Replacement.ClearFormatting
 Selection.Find.Replacement.Font.Color = wdColorBlue
 With Selection.Find
 .Text = Findarray(i, 1)
 .Replacement.Text = Findarray(i, 1)
 .Forward = True
 .Format = True
 .MatchWholeWord = True
 End With
Selection.Find.Execute Replace:=wdReplaceAll
ActiveDocument.Save
 Next x
 Next i
End Sub    

Screenshot of the excel spreedsheet

Screenshot of Word document

Answer 1

Some general principles when working with VBA are:

1. Avoid using the Selection object as it will slow your code down immensely, especially in a situation like this, as the screen has to be redrawn each time. Turning off ScreenUpdating won't help much.
2. For Each ... Next loops generally execute more quickly than using an index counter.
3. Ensure that you include Option Explicit at the top of your module to remind you to declare all variables. This is most easily achieved in the VBE by selecting Tools | Options | Require Variable Declaration as that will add it to every new module you add.

The following code replaces the code in your example starting from after you finish with Excel. Given the number of iterations required to process 500 sections 190 times it still isn't going to be fast but it should execute more quickly than your current code.

Set doc = ActiveDocument
For i = 2 To UBound(findArray)
    For Each sec In doc.Sections
        Set findRange = sec.Range
        With findRange.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Text = findArray(i, 1)
            .Forward = True
            .Format = True
            .MatchWholeWord = True
        End With
        If findRange.Find.Execute Then
            ActiveDocument.Footnotes.Add Range:=findRange, Text:=replArray(i, 1)
        End If
        Set findRange = sec.Range
        With findRange.Find
            .Replacement.ClearFormatting
            .Replacement.Font.Color = wdColorBlue
            .Text = findArray(i, 1)
            .Replacement.Text = findArray(i, 1)
            .Forward = True
            .Format = True
            .MatchWholeWord = True
        End With
        findRange.Find.Execute Replace:=wdReplaceAll
        doc.Save
    Next sec
Next i
Application.ScreenUpdating = True