Find and replace VBA macro too large

Question

I'm using this macro, to search and replace values in multiple word documents.

The problem is, that I have to many values, that should be changed and it won't run, saying :

Procedure is too large

I tried to find a solution, but nothing worked so far. I would be really grateful, if someone could offer a solution!

Sub DoReplace()

Const Find1 = "FIND TEXT"
Const Replace1 = "REPLACE TEXT"

Const Find2 = "FIND TEXT"
Const Replace2 = "REPLACE TEXT"

Const Find3 = "FIND TEXT"
Const Replace3 = "REPLACE TEXT"

Dim FilePick As FileDialog
Dim FileSelected As FileDialogSelectedItems
Dim WordFile As Variant  ' FileName placeholder in selected files loop
Dim FileJob As String    ' Filename for processing

Dim WorkDoc As Object
Dim WholeDoc As Range
Dim FooterDoc As Range

On Error GoTo DoReplace_Error

    Set FilePick = Application.FileDialog(msoFileDialogFilePicker)

    With FilePick
        .Title = "Choose Report Template"
        .Filters.Clear
        .Filters.Add "Word Documents & Templates", "*.do*"
        .Filters.Add "Word 2003 Document", "*.doc"
        .Filters.Add "Word 2003 Template", "*.dot"
        .Filters.Add "Word 2007 Document", "*.docx"
        .Filters.Add "Word 2007 Template", "*.dotx"
        .Show
    End With

    Set FileSelected = FilePick.SelectedItems

    If FileSelected.Count <> 0 Then

        For Each WordFile In FileSelected

            FileJob = WordFile

            Set WorkDoc = Application.Documents.Open(FileJob, , , , , , , , , , , False)

            Set WholeDoc = WorkDoc.Content
            Set FooterDoc = WorkDoc.Sections(1).Footers(wdHeaderFooterPrimary).Range
            Set FooterPage1 = WorkDoc.Sections(1).Footers(wdHeaderFooterFirstPage).Range

            With FooterPage1
                .Find.Execute Find1, True, True, , , , True, , , Replace1, wdReplaceAll
                .Find.Execute Find2, True, True, , , , True, , , Replace2, wdReplaceAll
                .Find.Execute Find3, True, True, , , , True, , , Replace3, wdReplaceAll
            End With

            With FooterDoc
                .Find.Execute Find1, True, True, , , , True, , , Replace1, wdReplaceAll
                .Find.Execute Find2, True, True, , , , True, , , Replace2, wdReplaceAll
                .Find.Execute Find3, True, True, , , , True, , , Replace3, wdReplaceAll
            End With

            With WholeDoc.Find
                .Execute Find1, True, True, , , , True, , , Replace1, wdReplaceAll
                .Execute Find2, True, True, , , , True, , , Replace2, wdReplaceAll
                .Execute Find3, True, True, , , , True, , , Replace3, wdReplaceAll

            End With

            WorkDoc.Save
            WorkDoc.Close

        Next

    End If

    MsgBox "Completed"

DoReplace_Exit:

    Set WholeDoc = Nothing
    Set FilePick = Nothing

    Set WorkDoc = Nothing
    Set FooterDoc = Nothing

    Exit Sub

DoReplace_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure DoReplace of VBA Document ReplaceMulti"
    Resume DoReplace_Exit

End Sub

Answer 1

This is a sample of how to approach this situation.

Option Explicit

Sub DoReplace()

    Dim FilesSelected As FileDialogSelectedItems
    Dim WordFile As Variant    ' FileName placeholder in selected files loop

    Dim WorkDoc As Document
    Dim WholeDoc As Range
    Dim FooterDoc As Range
    Dim FooterPage1 As Range
    Dim arrPair(0 To 2, 0 To 1) As String


    On Error GoTo DoReplace_Error

    ' Load the Array with pairs
    arrPair(0, 0) = "FIND TEXT"
    arrPair(0, 1) = "REPLACE TEXT"
    arrPair(1, 0) = "FIND TEXT"
    arrPair(1, 1) = "REPLACE TEXT"
    arrPair(2, 0) = "FIND TEXT"
    arrPair(2, 1) = "REPLACE TEXT"

    ' Get all the selected files
    Set FilesSelected = GetSelectedFiles

    If FilesSelected.Count <> 0 Then

        For Each WordFile In FilesSelected

            Set WorkDoc = Application.Documents.Open(WordFile, , , , , , , , , , , False)

            Set WholeDoc = WorkDoc.Content
            Set FooterDoc = WorkDoc.Sections(1).Footers(wdHeaderFooterPrimary).Range
            Set FooterPage1 = WorkDoc.Sections(1).Footers(wdHeaderFooterFirstPage).Range

            ' Replace the values
            Call FindAndReplace(arrPair, WholeDoc)
            Call FindAndReplace(arrPair, FooterDoc)
            Call FindAndReplace(arrPair, FooterPage1)

            WorkDoc.Close SaveChanges:=True
        Next

    End If

    MsgBox "Completed"

DoReplace_Exit:

    Set WholeDoc = Nothing

    Set WorkDoc = Nothing
    Set FooterDoc = Nothing

    Exit Sub


DoReplace_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure DoReplace of VBA Document ReplaceMulti"
    Resume DoReplace_Exit

End Sub

' Procedure to find and replace.
Sub FindAndReplace(ByVal arrValuePair As Variant, ByRef oSection As Object)

    Dim i As Long

    If UBound(arrValuePair, 2) = 1 Then
        With oSection
            For i = LBound(arrValuePair, 1) To UBound(arrValuePair, 1)
                .Find.Execute arrValuePair(i, 0), True, True, , , , True, , , arrValuePair(i, 1), wdReplaceAll
            Next i
        End With
    End If

End Sub


' Function to get the collection of selected files.
Function GetSelectedFiles() As FileDialogSelectedItems

    Dim FilePick As FileDialog

    Set FilePick = Application.FileDialog(msoFileDialogFilePicker)

    With FilePick
        .AllowMultiSelect = True
        .Title = "Choose Report Template"
        .Filters.Clear
        .Filters.Add "Word Documents & Templates", "*.do*"
        .Filters.Add "Word 2003 Document", "*.doc"
        .Filters.Add "Word 2003 Template", "*.dot"
        .Filters.Add "Word 2007 Document", "*.docx"
        .Filters.Add "Word 2007 Template", "*.dotx"
        .Show
    End With

    'Return the value
    Set GetSelectedFiles = FilePick.SelectedItems

End Function

I hope this helps. :)