MS Word Report from Excel Generator Works but Runs Slowly

Good Morning All,

I have frankensteined a report generator that will function for our company purposes from many useful sets of code. The workflow is for a user to select a template from a list within excel, import relevant data pieces, and then output a preliminary MS Word report. This MS Word report will be built from a Find Replace loop that iterates through the body of the text as well as the headers and footers of the document. It all works as intended, but I believe could be a bit quicker. The main time expenditure seems to come from expanding the Find Replace loop to encapsulate the headers and footers. While I have gotten the code to function, I'm assuming there's a more efficient or less data heavy means of accomplishing the same goal. My hope is that one of you would be able to whittle away at the processing time without losing any of the function or versatility of the application.

This is my first post so I can't attach links, but the first attached code snippet below was pulled from an application built by ExcelForFreelancers. The video showing it can be found by looking for the youtube video titled 'How to Create Custom Word Documents From Excel WITHOUT Mail Merge'. The second code snippet came from Charles Kenyon's reply to a user question on 'Stackoverflow' titled 'Find/Replace Text from Headers in a Word Document Using VBA in Excel'.



Sub Create_Geo()

Dim CustRow, CustCol, LastRow, TemplRow, DaysSince, FrDays, ToDays As Long
Dim DocLoc, TagName, TagValue, TemplName, FileName As String
Dim CurDt, LastAppDt As Date
Dim WordDoc, WordApp, OutApp, OutMail As Object
Dim WordContent As Word.Range
With Worksheets("Sheet1")

If .Range("B1").Value = Empty Then
MsgBox "Please select a correct template from the drop down list"
.Range("B1").Select
Exit Sub
End If
DocLoc = Application.WorksheetFunction.VLookup(Range("B1").Value, Worksheets("Templates").Range("E6:F25"), 2, False)

'Open Word Template
On Error Resume Next 'If Word is already running
Set WordApp = GetObject("Word.Application")
If Err.Number <> 0 Then
'Launch a new instance of Word
Err.Clear
'On Error GoTo Error_Handler
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True 'Make the application visible to the user
End If

Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False) 'Open Template
LastRow = .Range("A9999").End(xlUp).Row 'Determine Last Row in Table

For CustRow = 6 To LastRow 'Move Through Items.
TagName = .Cells(CustRow, 1).Value 'Tag Name
TagValue = .Cells(CustRow, 2).Value 'Tag Value
Call FindReplaceAlmostAnywhere(WordDoc, TagName, TagValue)
Next CustRow

FileName = ThisWorkbook.Path & "\" & .Range("B6").Value & " Preliminary Report"

If .Range("I3").Value = "PDF" Then
FileName = FileName & ".pdf" 'Create full filename & Path with current workbook location, Last Name & First Name
WordDoc.ExportAsFixedFormat OutputFileName:=FileName, ExportFormat:=wdExportFormatPDF
WordDoc.SaveAs FileName
WordDoc.Close False
Else: 'If Word
FileName = FileName & ".docx"
WordDoc.SaveAs FileName
End If
If .Range("P3").Value = "Print" Then
WordDoc.PrintOut
WordDoc.Close
End If
' Kill (FileName) 'Deletes the PDF or Word that was just created
WordApp.Quit
End With

End Sub

Public Sub FindReplaceAlmostAnywhere(WordDoc, FindText, ReplaceText)
Dim rngStory As Word.Range
Dim lngJunk As Long
'Fix the skipped blank Header/Footer problem as provided by Peter Hewett
lngJunk = WordDoc.Sections(1).Headers(1).Range.StoryType
'Iterate through all story types in the current document
For Each rngStory In WordDoc.StoryRanges
'Iterate through all linked stories
Do
With rngStory.Find
.Text = FindText
.Replacement.Text = ReplaceText
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
'Get next linked story (if any)
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next
End Sub

The image below is a screenshot of the starting information, while the code to edit is attached above.

Attachment 777251