I have been modifying a macro found here but am stuck. I need to automatically create, email, and file a PDF for all worksheets that have an email address in cell E1. I am using the following code but am not able to get it to work. I appreciate any assistance you can provide.
Sub create_and_email_pdf()
' Author - Philip Treacy :: https://www.linkedin.com/in/philiptreacy
' Date - 14 Oct 2013
' Create a PDF from the current sheet and email it as an attachment through Outlook
Dim EmailSubject As String, EmailSignature As String
Dim CurrentMonth As String, DestFolder As String, PDFFile As String
Dim Email_To As String, Email_CC As String, Email_BCC As String
Dim OpenPDFAfterCreating As Boolean, AlwaysOverwritePDF As Boolean, DisplayEmail As Boolean
Dim OverwritePDF As VbMsgBoxResult
Dim OutlookApp As Object, OutlookMail As Object
CurrentMonth = ""
' **************************************************
' ** You Can Change These Variables ******
EmailSubject = "Performance Improvement Bonus Calculation " 'Change this to change the subject of the email. The current month is added to end of subj line
OpenPDFAfterCreating = False 'Change this if you want to open the PDF after creating it : TRUE or FALSE
AlwaysOverwritePDF = False 'Change this if you always want to overwrite a PDF that already exists :TRUE or FALSE
DisplayEmail = True 'Change this if you don't want to display the email before sending. Note, you must have a TO email address specified for this to work
Email_To = ActiveSheet.Range("E1") 'Change this if you want to specify To email e.g. ActiveSheet.Range("H1") to get email from cell H1
Email_CC = ""
Email_BCC = ""
Email_Body = "Attached is your Performance Improvement bonus calculation. Please contact me if you have any questions."
' ***************************************************
'Prompt for file destination
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
DestFolder = .SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
End With
'Current month/year stored in M1 (this is a merged cell)
CurrentMonth = Mid(ActiveSheet.Range("M1").Value, InStr(1, ActiveSheet.Range("M1").Value, " ") + 1)
'Create new PDF file name including path and file extension
PDFFile = DestFolder & Application.PathSeparator & ActiveSheet.Name _
& "_" & CurrentMonth & ".pdf"
'If the PDF already exists
If Len(Dir(PDFFile)) > 0 Then
If AlwaysOverwritePDF = False Then
OverwritePDF = MsgBox(PDFFile & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", vbYesNo + vbQuestion, "File Exists")
On Error Resume Next
'If you want to overwrite the file then delete the current one
If OverwritePDF = vbYes Then
Kill PDFFile
Else
MsgBox "OK then, if you don't overwrite the existing PDF, I can't continue." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
Exit Sub
End If
Else
On Error Resume Next
Kill PDFFile
End If
If Err.Number 0 Then
MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
Exit Sub
End If
End If
'Create the PDF
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=OpenPDFAfterCreating
'Create an Outlook object and new mail message
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
'Display email and specify To, Subject, etc
With OutlookMail
.Display
.To = Email_To
.CC = Email_CC
.BCC = Email_BCC
.Subject = EmailSubject & CurrentMonth
.Body = Email_Body
.Attachments.Add PDFFile
If DisplayEmail = False Then
.Send
End If
End With
End Sub
Hi Todd,I sent a reply to your comment, thought you received it.
You should call the procedure from another procedure, because the email address is read outside your loop. You can start the loop before the variables (include the variables inside the loop), or use this code to loop through sheets and check if it needs to be sent (remove the For Next loop from your code):
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
ws.Activate
if Len(ActiveSheet.Cells(1,"E")) > 0 Then create_and_email_pdf
Next
End Sub
Cheers,
Catalin
I am getting a compile error at the ;
Also, and I know this is stupid, where do I insert the subroutine above?
Hi Todd,
Paste the code into the same module where your other code is, or even into a new code module, does not matter.
Looks like the browser changed the "greater than" sign to html equivalent, it should be:
if Len(ActiveSheet.Cells(1,"E")) > 0 Then create_and_email_pdf
In pseudo code, it simply says: if the length of the cell e1 text is greater than zero, then call the create_and_email_pdf procedure.
Instead of saying if the text is > 0, can it say if and email is entered into E1...
Practically, that's what it says already: if an email is entered in E1, the length of that cell's text will be greater than zero.
I can guess what's in your mind: you want to send the email in that exact moment when the email address is typed into cell E1? If this is the case, you have to use event driven codes: workbook-worksheet-events-excel-vba to call the create_and_email_pdf procedure.
There are some worksheets in the workbook that I use for variables and calculations that I don't want to email that have some text in E1. So I want to only send worksheets that have an email in E1.
Then it will work with what you already have, no need to change anything. I don't see why you need another way of checking the email from E1, the existing line will do what you need.
Why don't you simply test it, see how it works: put your own email in a few sheets, leave the rest with no email, run the code, see how many emails you receive...
Ok. Tried to run it now I am getting a Run time error '1004' at the following line
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=OpenPDFAfterCreating
Hi Todd,
Check the PDF Name, it's in these lines:
'Current month/year stored in M1 (this is a merged cell)
CurrentMonth = Mid(ActiveSheet.Range("M1").Value, InStr(1, ActiveSheet.Range("M1").Value, " ") + 1)
'Create new PDF file name including path and file extension
PDFFile = DestFolder & Application.PathSeparator & ActiveSheet.Name _
& "_" & CurrentMonth & ".pdf"
Add a line to display the name after these lines and make sure the file name and path is correct:
Msgbox PDFFile
OK. You lost me. I have know idea what you are talking about.
Catalin Bombea said
Hi Todd,Check the PDF Name, it's in these lines:
'Current month/year stored in M1 (this is a merged cell)
CurrentMonth = Mid(ActiveSheet.Range("M1").Value, InStr(1, ActiveSheet.Range("M1").Value, " ") + 1)
'Create new PDF file name including path and file extension
PDFFile = DestFolder & Application.PathSeparator & ActiveSheet.Name _
& "_" & CurrentMonth & ".pdf"' Add a line to display the name after these lines and make sure the file name and path is correct:
Msgbox PDFFile
The red code comes from your posted code, read your initial message. All you have to do is to identify the location of the red lines in your code and add the green line after the red lines in your code from your file.
That half-worked. 1. The macro tried to email worksheets that had something other than an email in cell E1 2. then half-way through the worksheets displayed a runtime error 1004 which showed the problem still at:
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=OpenPDFAfterCreating
even though the following worksheet was the same format with the email in E1.
Why would you keep something in E1 other than email address?
Sub SendAllSheets()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
ws.Activate
if ActiveSheet.Cells(1,"E").Value Like "*@*" Then create_and_email_pdf
Next
End Sub
If E1 can have text values containing the "@" and it's not an email, then you will need to use a function that can evaluate an email address using an email pattern, with regular expressions.
For the other error, can't see a reason without testing the file. If you can remove most sheets and leave some test sheets with fake emails so we can test, will be able to help.
Hi - be gentle with me, first post. I am an absolute novice at VBA and learning as I go. I have a similar situation as to what Todd was trying to create. I have got it working so that I can save to PDF and then email using an email address in a certain field on individual sheets, but what I need now is for it to loop through the workbook sending out each sheet that has an email in address in a certain cell. What I'm confused about is where in the coding I should be putting the additional coding referred to below. Apologies if this is a basic question - but thank you in advance for your help. The original coding provide in "VBA to Create PDF from Excel Worksheet Then Email It With Outlook" and the subsequent discussions has proved invaluable.
Sub SendAllSheets()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
ws.Activate
if ActiveSheet.Cells(1,"E").Value Like "*@*" Then create_and_email_pdf
Next
End Sub
