The following VB codes work fine to send pdf file to individual recipient based on Pivot Fields, deep thanks to Philip.
But, can these codes be modified send pivot field filtered range in Excel File format, not pdf format to recipient.
Option Explicit
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
' ** You Can Change The Values of These Variables ***
EmailSubject = "Outstanding POs copy in NAS " '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("Pivot Table").PivotTables("PivotTable1")
pt.PivotCache.MissingItemsLimit = xlMissingItemsNone
pt.PivotCache.Refresh
Set pf = pt.PivotFields("PIC")
Set OutlookApp = CreateObject("Outlook.Application")
' Setup the sheet to print one 1 page
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.PrintTitleRows = "$3:$3"
.FitToPagesWide = 15
.FitToPagesTall = 15
.Orientation = xlLandscape
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0)
.BottomMargin = Application.InchesToPoints(0)
.HeaderMargin = Application.InchesToPoints(0)
.FooterMargin = Application.InchesToPoints(0)
End With
Application.PrintCommunication = True
' Go through every Staff 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 Staff 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 GoTo 0
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
''On Error GoTo 0
On Error Resume Next
'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
.htmlbody = "<p style=""font-family:Times New Roman Bold;font-style:italic;font-size:18px;"">Dear POs PIC,</p>"
.htmlbody = .htmlbody & "<p style=""font-family:Times New Roman Bold;font-style:italic;font-size:16px;"">Good day !</p>"
.htmlbody = .htmlbody & "<p style=""font-family:Times New Roman Bold;font-style:italic;font-size:16px;"">Attached please subject list as of today, please help to store the POs soonest.</p>"
.htmlbody = .htmlbody & "<span style=""font-family:Times New Roman Bold;font-style:italic;font-size:16px;"">Best Regards,</span><br/>"
.htmlbody = .htmlbody & "<span style=""font-family:Times New Roman Bold;font-size:16px;"">David</span><br/>"
.htmlbody = .htmlbody & "<span style=""font-family:Times New Roman Bold;font-size:18px;"">ABC Ltd.</span>"
.Display
.To = WorksheetFunction.VLookup(Range("B1").Value, Worksheets("Staffs").Range("Managers"), 2, False)
'To = WorksheetFunction.VLookup(Range("B2").Value, Worksheets("Staffs").Range("Staffs"), 2)
'.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 = True 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
Here is an example that is using a RangeToHTML function, you can use it to pass the pivot range to email body.
Will have a go, deep thanks Catalin..