Sub CreateWordDocuments()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 Sheet1
If .Range("B3").Value = Empty Then
MsgBox "Please select a correct template from the drop down list"
.Range("G3").Select
Exit Sub
End If
TemplRow = .Range("B3").Value 'Set Template Row
TemplName = .Range("G3").Value 'Set Template Name
'FrDays = .Range("L3").Value 'Set From Days
'ToDays = .Range("N3").Value 'Set To Days
DocLoc = Sheet2.Range("F" & TemplRow).Value 'Word Document Filename
'Open Doc Template if not already open
On Error Resume Next 'If Word is already running
Set WordApp = GetObject("Word.Application")
If Err.Number <> 0 Then
'Launches 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
LastRow = .Range("E9999").End(xlUp).Row 'Determines Last Row in Table
For CustRow = 8 To LastRow
'DaysSince = .Range("M" & CustRow).Value
If TemplName <> .Range("N" & CustRow).Value Then 'And DaysSince >= FrDays And DaysSince <= ToDays Then
Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False) 'Opens Template
For CustCol = 5 To 25 'Move Through Columns
TagName = .Cells(7, CustCol).Value 'Tag Name (First mail merge cell)
TagValue = .Cells(CustRow, CustCol).Value 'Tag Value
With WordDoc.Content.Find 'Look for merge field in doc
.Text = TagName 'what you're looking for
.Replacement.Text = TagValue 'what you're going to replace with
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll 'Actually replaces - idea:Find & Replace all instances
End With
Next CustCol
'Now, what are we going to do wit merged doc? Is it going to be Word or PDF?
If .Range("I3").Value = "PDF" Then
FileName = ThisWorkbook.Path & "\" & .Range("E" & CustRow).Value & "_" & .Range("F" & CustRow).Value & ".pdf" 'Creates full filename & Path with current workbook location (Last Name & First Name)
WordDoc.ExportAsFixedFormat OutputFileName:=FileName, ExportFormat:=wdExportFormatPDF 'takes pdf and prints
WordDoc.Close False
Else: 'If Word
FileName = ThisWorkbook.Path & "\" & .Range("E" & CustRow).Value & "_" & .Range("F" & CustRow).Value & ".docx"
WordDoc.SaveAs FileName 'template won't be touched, saves as new file
End If
'.Range("N" & CustRow).Value = TemplName 'Template Name
'.Range("O" & CustRow).Value = Now
If .Range("P3").Value = "Email" Then
Set OutApp = CreateObject("Outlook.Application") 'Creates Outlook Application
Set OutMail = OutApp.CreateItem(0) 'Creates Email
With OutMail
.To = Sheet1.Range("K" & CustRow).Value 'K is the column with email listed
.Subject = "Hi, " & Sheet1.Range("I" & CustRow).Value & " We Miss You"
.Body = "Hello, " & Sheet1.Range("I" & CustRow).Value & " Its been a while since we have seen you so we wanted to send you a special letter. Please see the attached file"
.Attachments.Add FileName
.Display 'To send without Displaying change .Display to .Send
End With
Else: 'Print Out
WordDoc.PrintOut
WordDoc.Close
End If
'Kill (FileName) 'Deletes the PDF or Word that was just created
End If '3 condition met
Next CustRow
WordApp.Quit
End With
End Sub