I have the below code that sends orders to multiple suppliers
However once finished the table has a filter remaining that I'd like removed
Also I want to then print the entire worksheet at the end
foot note: sometimes it fails to complete emails and closes excel, would anyone know why?
Sub EmailPTReports()
Dim pt As PivotTable
Dim pf As PivotField
Dim pi As PivotItem
Dim i As Long
Dim EmailSubject As String
Dim PDFFile As String
Dim Email_To As String, Email_CC As String, Email_BCC As String
Dim DisplayEmail As Boolean
Dim OutlookApp As Object, OutlookMail As Object
Dim strbody As String
EmailSubject = "Order" 'Change this to change the subject of the email.
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 = "" 'Change this if you want to specify To email e.g. ActiveSheet.Range("H1") to get email from cell H1
Email_CC = ""
Email_BCC = ""
Set pt = Sheets("PURCHASE ORDER BY SUPPLIER").PivotTables("PivotTable2")
pt.PivotCache.MissingItemsLimit = xlMissingItemsNone
pt.PivotCache.Refresh
Set pf = pt.PivotFields("SUPPLIER NAME")
Set OutlookApp = CreateObject("Outlook.Application")
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.FitToPagesWide = 1
.FitToPagesTall = 1
.Orientation = xlPortrait
End With
Application.PrintCommunication = True
' Go through every category in turn
For i = 1 To pf.PivotItems.Count
pf.CurrentPage = pf.PivotItems(i).Name
PDFFile = Environ("Temp") & Application.PathSeparator & pf.PivotItems(i).Name & ".pdf"
' Replace / in category name as this is an invalid character for filenames
PDFFile = Replace(PDFFile, "/", "_")
' Delete PDFFile if it already exists so that
' we can create new file later with the same name
On Error Resume Next
If Len(Dir(PDFFile)) > 0 Then Kill PDFFile
' If there's an error deleting the file
If Err.Number <> 0 Then
MsgBox "Unable to delete " & PDFFile & ". 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
' Reset error handling to normal
On Error GoTo 0
'Create the PDF
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFFile, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
'Create a new mail message
Set OutlookMail = OutlookApp.CreateItem(0)
'Display email and specify To, Subject, etc
With OutlookMail
.Display
.To = WorksheetFunction.VLookup(Range("C5").Value, Worksheets("SUPPLIERS").Range("TABLE6"), 3)
'.CC = Email_CC
'.BCC = Email_BCC
.Subject = EmailSubject
.Attachments.Add PDFFile
' Change this to True to automatically send emails without first viewing them
If DisplayEmail = False Then
.Send
End If
End With
' Delete the temp file we just created
Kill PDFFile
Next i
' Tidy up
Set OutlookApp = Nothing
Set OutlookMail = Nothing
End Sub
However once finished the table has a filter remaining that I'd like removed
Also I want to then print the entire worksheet at the end
foot note: sometimes it fails to complete emails and closes excel, would anyone know why?
Sub EmailPTReports()
Dim pt As PivotTable
Dim pf As PivotField
Dim pi As PivotItem
Dim i As Long
Dim EmailSubject As String
Dim PDFFile As String
Dim Email_To As String, Email_CC As String, Email_BCC As String
Dim DisplayEmail As Boolean
Dim OutlookApp As Object, OutlookMail As Object
Dim strbody As String
EmailSubject = "Order" 'Change this to change the subject of the email.
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 = "" 'Change this if you want to specify To email e.g. ActiveSheet.Range("H1") to get email from cell H1
Email_CC = ""
Email_BCC = ""
Set pt = Sheets("PURCHASE ORDER BY SUPPLIER").PivotTables("PivotTable2")
pt.PivotCache.MissingItemsLimit = xlMissingItemsNone
pt.PivotCache.Refresh
Set pf = pt.PivotFields("SUPPLIER NAME")
Set OutlookApp = CreateObject("Outlook.Application")
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.FitToPagesWide = 1
.FitToPagesTall = 1
.Orientation = xlPortrait
End With
Application.PrintCommunication = True
' Go through every category in turn
For i = 1 To pf.PivotItems.Count
pf.CurrentPage = pf.PivotItems(i).Name
PDFFile = Environ("Temp") & Application.PathSeparator & pf.PivotItems(i).Name & ".pdf"
' Replace / in category name as this is an invalid character for filenames
PDFFile = Replace(PDFFile, "/", "_")
' Delete PDFFile if it already exists so that
' we can create new file later with the same name
On Error Resume Next
If Len(Dir(PDFFile)) > 0 Then Kill PDFFile
' If there's an error deleting the file
If Err.Number <> 0 Then
MsgBox "Unable to delete " & PDFFile & ". 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
' Reset error handling to normal
On Error GoTo 0
'Create the PDF
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFFile, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
'Create a new mail message
Set OutlookMail = OutlookApp.CreateItem(0)
'Display email and specify To, Subject, etc
With OutlookMail
.Display
.To = WorksheetFunction.VLookup(Range("C5").Value, Worksheets("SUPPLIERS").Range("TABLE6"), 3)
'.CC = Email_CC
'.BCC = Email_BCC
.Subject = EmailSubject
.Attachments.Add PDFFile
' Change this to True to automatically send emails without first viewing them
If DisplayEmail = False Then
.Send
End If
End With
' Delete the temp file we just created
Kill PDFFile
Next i
' Tidy up
Set OutlookApp = Nothing
Set OutlookMail = Nothing
End Sub
