Find and replace VBA macro too large - vba

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. :)