Hi all,
I'm relatively new to excel vba and i'm i've created a spreadsheet that allows the user to select three options. "Email as PDF", "Open Documents" and "Email as Word Document". The below VBA currently opens only one document whereas i'm looking to open three documents/PDF for all three options. The below vba works perfectly for opening just one document/pdf but i can seem to figure out how to open multiple documents.
I'd appreciate any help on this.
Here's what i've done so far;
I'm relatively new to excel vba and i'm i've created a spreadsheet that allows the user to select three options. "Email as PDF", "Open Documents" and "Email as Word Document". The below VBA currently opens only one document whereas i'm looking to open three documents/PDF for all three options. The below vba works perfectly for opening just one document/pdf but i can seem to figure out how to open multiple documents.
I'd appreciate any help on this.
Here's what i've done so far;
Code:
Option Explicit
Sub CreateWordDocumentsv2()
Dim CustRow, CustCol As Long
Dim docloc, docloc2, docloc3, TagName, TagValue, FileName, FileName2, FileName3, ans As String
Dim WordDoc, WordDoc2, WordDoc3, WordApp, WordApp2, WordApp3, OutApp, OutMail As Object
Dim WordContent As Word.Range
With Sheet2
If .Range("O8").Value = Empty Then
MsgBox "Please enter a valid reference number"
Sheets("Start").Activate
Exit Sub
End If
'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")
Set WordApp2 = CreateObject("Word.Application")
Set WordApp3 = CreateObject("Word.Application")
WordApp.Visible = True 'Make the application visible to the user
End If
'sets which documents to open
If .Range("O10") = "Yes" And .Range("O9") = "Pack1" Then
docloc = "D:\Users\Lee\Desktop\Test\Doc1.docx"
docloc2 = "D:\Users\Lee\Desktop\Test\Doc2.docx"
docloc3 = "D:\Users\Lee\Desktop\Test\Doc3.docx"
ElseIf .Range("O10") = "No" And .Range("O9") = "Pack2" Then 'HP Template
docloc = "D:\Users\Lee\Desktop\Test\Doc3.docx"
docloc2 = "D:\Users\Lee\Desktop\Test\Doc4.docx"
docloc3 = "D:\Users\Lee\Desktop\Test\Doc5.docx"
End If
For CustRow = 42 To 42
Set WordDoc = WordApp.Documents.Open(FileName:=docloc, ReadOnly:=False) 'Open Template
Set WordDoc2 = WordApp2.Documents.Open(FileName2:=docloc2, ReadOnly:=False) 'Open Template
Set WordDoc3 = WordApp3.Documents.Open(FileName3:=docloc3, ReadOnly:=False) 'Open Template
For CustCol = 2 To 39 'Move Through Columns
TagName = .Cells(41, 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
With WordDoc2.Content.Find
.Text = TagName
.Replacement.Text = TagValue
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll 'Find & Replace all instances
End With
With WordDoc3.Content.Find
.Text = TagName
.Replacement.Text = TagValue
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll 'Find & Replace all instances
End With
Next CustCol
If .Range("N14").Value = "Email as PDF" Then
ans = MsgBox("Are you sending the documents to the customer?", vbYesNo)
FileName = ThisWorkbook.Path & "\" & .Range("E8").Value & "1" & ".pdf" 'Create full filename
WordDoc.ExportAsFixedFormat OutputFileName:=FileName, ExportFormat:=wdExportFormatPDF
WordDoc.Close False
FileName2 = ThisWorkbook.Path & "\" & .Range("E9").Value & ".pdf" 'Create full filename
WordDoc2.ExportAsFixedFormat OutputFileName:=FileName2, ExportFormat:=wdExportFormatPDF
WordDoc2.Close False
FileName3 = ThisWorkbook.Path & "\" & .Range("E10").Value & ".pdf" 'Create full filename
WordDoc3.ExportAsFixedFormat OutputFileName:=FileName3, ExportFormat:=wdExportFormatPDF
WordDoc3.Close False
Set OutApp = CreateObject("Outlook.Application") 'Create Outlook Application
Set OutMail = OutApp.CreateItem(0) 'Create Email
With OutMail
.To = ans
If ans = vbYes Then
.To = Sheet2.Range("S8").Value
Else
.To = ""
End If
.Subject = "Test Subject"
.Body = "Hello, this is a test"
.Attachments.Add FileName
.Attachments.Add FileName2
.Attachments.Add FileName3
.Display
WordApp.Quit
WordApp2.Quit
WordApp3.Quit
End With
ElseIf Range("N14").Value = "Open Documents" Then
FileName = ThisWorkbook.Path & "\" & .Range("E9").Value & ".docx"
'WordDoc.SaveAs FileName
FileName2 = ThisWorkbook.Path & "\" & .Range("E9").Value & ".docx"
'WordDoc2.SaveAs FileName2
FileName3 = ThisWorkbook.Path & "\" & .Range("E9").Value & ".docx"
'WordDoc3.SaveAs FileName3
'WordDoc.SaveAs FileName
ElseIf Range("N14").Value = "Email as Word Document" Then
ans = MsgBox("Are you sending the documents to the customer?", vbYesNo)
FileName = ThisWorkbook.Path & "\" & .Range("E9").Value & ".docx"
WordDoc.SaveAs FileName
FileName2 = ThisWorkbook.Path & "\" & .Range("E9").Value & ".docx"
WordDoc.SaveAs FileName2
FileName3 = ThisWorkbook.Path & "\" & .Range("E9").Value & ".docx"
WordDoc.SaveAs FileName3
Set OutApp = CreateObject("Outlook.Application") 'Create Outlook Application
Set OutMail = OutApp.CreateItem(0) 'Create Email
With OutMail
.To = ans
If ans = vbYes Then
.To = Sheet2.Range("S8").Value
Else
.To = ""
End If
.Subject = "Test Subject"
.Body = "Hello, this is a test"
.Attachments.Add FileName
.Attachments.Add FileName2
.Attachments.Add FileName3
.Display 'To send without Displaying change .Display to .Send
WordApp.Quit
End With
'Else: 'Print Out
'WordDoc.PrintOut
'WordDoc.Close
End If
Next CustRow
Kill (FileName) 'Deletes the PDF or Word that was just created
Kill (FileName2) 'Deletes the PDF or Word that was just created
Kill (FileName3) 'Deletes the PDF or Word that was just created
End With
End Sub
