I'm having challenges identifying the errors on the code. Although, I got this code from a video tutorial I watched and I was able to create almost the exact Excel spreadsheet but it doesn't tend to execute the task of replacing the details in a word doc with that on the table.
I don't mind rewriting/using a different code that will work accurately.
Your assistance will be very much appreciated.
I don't mind rewriting/using a different code that will work accurately.
Your assistance will be very much appreciated.
VBA Code:
Sub CreateWordDocuments()
Dim CustRow, CustCol, LastRow, TemplRow As Long
Dim DocLoc, TagName, TagValue, TemplName, FileName As String
Dim WordDoc, WordApp, OutApp, OutMail As Object
Dim WordContent As Word.Range
With Sheet3
If .Range("Q2").Value = Empty Then
MsgBox "Please select a correct template from the drop down list"
.Range("E2").Select
Exit Sub
End If
TemplRow = .Range("Q2").Value 'Set Template Row
TemplName = .Range("E2").Value 'Set Template Name
DocLoc = Sheet1.Range("E" & TemplRow).Value 'Word Document Filename
'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
LastRow = .Range("A9999").End(xlUp).Row 'Determine Last Row in Table
For CustRow = 5 To LastRow
Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False) 'Open Template
For CustCol = 5 To 13 'Move Through 9 Columns
TagName = .Cells(6, CustCol).Value 'Tag Name
TagValue = .Cells(CustRow, CustCol).Value 'Tag Value
With WordDoc.Content.Find
.Text = TagName
.Replacement.Text = TagValue
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll 'Find & Replace all instances
End With
Next CustCol
If .Range("I3").Value = "PDF" Then
FileName = ThisWorkbook.Path & "\" & .Range("E" & CustRow).Value & "_" & .Range("F" & CustRow).Value & ".pdf" 'Create full filename & Path with current workbook location, Last Name & First Name
WordDoc.ExportAsFixedFormat OutputFileName:=FileName, ExportFormat:=wdExportFormatPDF
WordDoc.Close False
Else: 'If Word
FileName = ThisWorkbook.Path & "\" & .Range("D" & CustRow).Value & "_" & .Range("E" & CustRow).Value & ".docx"
WordDoc.SaveAs FileName
End If
If .Range("I2").Value = "Email" Then
Set OutApp = CreateObject("Outlook.Application") 'Create Outlook Application
Set OutMail = OutApp.CreateItem(0) 'Create Email
With OutMail
.To = Sheet3.Range("P" & CustRow).Value
.Subject = "Hi, " & Sheet3.Range("E" & CustRow).Value
.Body = "Hello, " & Sheet3.Range("F" & CustRow).Value
.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