Email as PDF after Sorted Name (Column 12)

NZAS

Board Regular
Joined
Oct 18, 2012
Messages
116
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
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
1579131000946.png

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:

Some videos you may like

Excel Facts

What do {} around a formula in the formula bar mean?
{Formula} means the formula was entered using Ctrl+Shift+Enter signifying an old-style array formula.

ajetrumpet

Banned for being rude
Joined
Apr 12, 2008
Messages
569
Office Version
  1. 365
  2. 2016
  3. 2007
Platform
  1. Windows
so what exactly is left for you to do? you say:
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.
not sure I follow that. In addition, your code is *way* too small to read. Not sure how you got it that way. Make it bigger and more readable, and besides, put it in CODE tags. I'm not sure anyone will want to read all of it cuz it's so long, but it's worth a shot.
 

NZAS

Board Regular
Joined
Oct 18, 2012
Messages
116
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
I think I have worked out why this did not work.
It is where the filters were being set I had an apostrophy ' in front of the line of code that does the filter for column 2.
Sometimes it is worth a second look with another set of eyes
Thanks
 
Last edited:
Solution

Watch MrExcel Video

Forum statistics

Threads
1,118,807
Messages
5,574,427
Members
412,592
Latest member
moonsugar
Top