I have a worksheet that is populated with data. It has rows with a date Monday to Friday in it with detail under each date.
What I would like is some code to create a PDF and set up to be Emailed to addresses listed in the worksheet but I need it to be able to filter so only their details are sent (say TOLL) but will still leave the row where the Day is so it created a PDF and then sends by email I can get it to work for all names in column. I can do this filtering and get a PDF of all data then sending to addresses.
Have managed to do the above but does not leave the row where the Date and day is to give a separation so not to show as a single list. It also save the PDF to a folder This code is attached
What I would like is some code to create a PDF and set up to be Emailed to addresses listed in the worksheet but I need it to be able to filter so only their details are sent (say TOLL) but will still leave the row where the Day is so it created a PDF and then sends by email I can get it to work for all names in column. I can do this filtering and get a PDF of all data then sending to addresses.
Have managed to do the above but does not leave the row where the Date and day is to give a separation so not to show as a single list. It also save the PDF to a folder This code is attached
VBA Code:
Sub create_and_email_pdf_TOLL()
'This creates a PDF file of active worksheet (or a range if named this one is PrintArea)
'then will save it to a folder and then email to Toll stored in file
' 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
Dim Recipients, f
CurrentMonth = ""
' *****************************************************
' ***** You Can Change These Variables *********
EmailSubject = "Toll Dispatch Sheet " '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 = Yes or FALSE = No
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. True =Yes, False=No, Note,
'you must have a TO email address specified for this to work
Recipients = Sheets("Email_Addresses").Range("Toll") 'Change this if you want to specify To email e.g. ActiveSheet.Range("H1") to get email from cell H1
' Change to Recipients = sheets("Email_Addresses).range("Toll")
For f = 1 To UBound(Recipients)
Email_To = Email_To & Recipients(f, 1) & "; "
Next f
Email_CC = "" 'Change this if you want to specify To email
Email_BCC = "" 'Change this if you want to specify To email
' ******************************************************
'Prompts for file folder destination to save PDF to
'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
DestFolder = "H:\00 Master Files\2019 Data\PDF Files "
'Current date stored in H6 (this is a merged cell)
CurrentMonth = Format(Range("adate"), "ddmmyy")
'Create new PDF file name including path and file extension
PDFFile = DestFolder & CurrentMonth & " TOLL Despatches.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
'Create the PDF
Application.ScreenUpdating = False
Sheets("Dispatch Sheet").UnProtect Password:="process"
With Sheets("Dispatch Sheet")
.Range("A2:Q2").Select
Selection.AutoFilter
'ActiveSheet.Range("$A$2:$Q$77").AutoFilter Field:=2, Criteria1:="<>"
ActiveSheet.Range("$A$2:$Q$77").AutoFilter Field:=14, Criteria1:= _
"TOLL"
'.Columns("Q:T").EntireColumn.Hidden = True
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=OpenPDFAfterCreating
'.Columns("Q:T").EntireColumn.Hidden = False
End With
'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
.Attachments.Add PDFFile
If DisplayEmail = False Then
'This automatically sends email if ' placed in front of .send
'.Send
End If
End With
ActiveSheet.Range("$A$2:$Q$77").AutoFilter Field:=14, Criteria1:=Array( _
"TOLL", "TOLL", "="), Operator:=xlFilterValues
ActiveSheet.Range("$A$2:$Q$77").AutoFilter Field:=14
'ActiveSheet.Range("$A$2:$Q$77").AutoFilter Field:=2
Selection.AutoFilter
Range("A3").Select
Sheets("Dispatch Sheet").Protect Password:="process"
Application.ScreenUpdating = True
End Sub
Last edited by a moderator:
