Option Explicit
Option Explicit
Sub Gen_Email_One_PivotTable()
'This is for 1 tables
'Do not make changes in this program
'From 1 Table only
Dim pf As PivotField
Dim pvtname As String
Dim lRow As Long
Dim cel As Range
Dim Pi As PivotItem
Dim OutApp As Object
Dim OutMail As Object
Dim ws As Worksheet
Dim rng As Range
Dim emailBody As String
Dim emailSignature As String
Dim rowCount As Long
Dim exportPath As String
Dim dateStr As String
Dim fileName As String
Dim TempWB As Workbook
Dim TempWS As Worksheet
Dim msg1 As String
Dim msg2 As String
Dim tfolder As String
Dim region1 As String
Dim tbl As String
pvtname = "PivotTable1"
Set ws = ActiveSheet
tfolder = Environ("TEMP")
dateStr = Format(Now, "dd_Mmm_yyyy")
' Prepare messages
msg1 = "Hi Rushikesh, <br><br> Please find below the detailed sales summary " & _
"for the " & "<region>" & " region as requested. The report includes the latest figures and trends, highlighting key" & _
" insights that may be useful for our upcoming discussions.<br><br> Should you require any further information or " & _
"clarification, feel free to reach out."
msg2 = "Hi Rushikesh,<br>Please find the attached excel file for a detailed sales summary " & _
"for the <region> region as requested. The report includes the latest figures and trends, highlighting key" & _
" insights that may be useful for our upcoming discussions. Should you require any further information or " & _
"clarification, feel free to reach out."
Application.StatusBar = "Start"
' Clear all filters in pivot
On Error Resume Next
For Each pf In ws.PivotTables(pvtname).RowFields
pf.ClearAllFilters
Next pf
On Error GoTo 0
' Find unique values
lRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
ws.Range("A3:A" & lRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range("A3:A" & lRow), CopyToRange:=ws.Range("L2"), Unique:=True
lRow = ws.Range("L1048576").End(xlUp).Row - 1
Set pf = ws.PivotTables(pvtname).PivotFields("Market")
' Get default signature
emailSignature = GetOutlookSignature()
' Get Outlook application
On Error Resume Next
Set OutApp = GetObject(, "Outlook.Application")
If OutApp Is Nothing Then
Set OutApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0
' Loop through each unique value
For Each cel In ws.Range("L3:L" & lRow)
pf.ClearAllFilters
' Set PivotItem visibility
For Each Pi In pf.PivotItems
Pi.Visible = (Pi.Name = cel.Value)
Next Pi
' Get the range of data to copy
lRow = ws.Range("A1048576").End(xlUp).Row
Set rng = ws.Range("A2:E" & lRow)
' Count number of rows
rowCount = rng.Rows.Count
' If data has 20 or fewer rows, send it via email
If rowCount <= 20 Then
' Create email body with left alignment
' emailBody = "<div style='text-align: left; font-family: Calibri; font-size: 11pt;'>" & _
' "<p>Hello,</p>" & _
' "<p>Please find the filtered data attached.</p>" & _
' "</div>"
'Prepare email body in HTML format
' tbl = RangeToHTML(rng) 'Replace(RangeToHTML(rng), "align=center", "align=left")
emailBody = "<html><body style='text-align: left;'>" & _
"<p style='font-family:Calibri; font-size:11pt; color:#000000; margin: 0;'>" & _
Replace(msg1, "<region>", cel.Value) & "<br>" & Replace(RangeToHTML(rng), "align=center", "align=left") & "</p></body></html>"
' Create and send the email
Set OutMail = OutApp.CreateItem(0)
With OutMail
.Display ' Use .Send to send directly
.To = "recipient@example.com" ' Change this to the recipient's email
.Subject = "Filtered Data: " & cel.Value
.HTMLBody = emailBody & emailSignature
End With
' GoTo endFunction
' If data has more than 20 rows, export it to a new Excel file
Else
' Create a new workbook
Set TempWB = Workbooks.Add
Set TempWS = TempWB.Sheets(1)
' Copy the filtered range to the new workbook
rng.Copy
TempWS.Range("A1").PasteSpecial Paste:=xlPasteValues
TempWS.Range("A1").PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
' Generate the file name and save the new workbook
fileName = cel.Value & "_" & dateStr & ".xlsx"
exportPath = tfolder & "\" & fileName
TempWB.SaveAs fileName:=exportPath, FileFormat:=xlOpenXMLWorkbook
TempWB.Close SaveChanges:=False
' Prepare email with the file attached
emailBody = "<html><body style='text-align: left;'>" & _
"<p style='font-family:Calibri; font-size:11pt; color:#000000; margin: 0;'>" & _
Replace(msg2, "<region>", cel.Value) & "<br>" & RangeToHTML(rng) & "</p></body></html>"
' Create and send the email with attachment
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = "recipient@example.com" ' Change this to the recipient's email
.Subject = "Filtered Data: " & cel.Value
.HTMLBody = emailBody & emailSignature
.Attachments.Add exportPath
.Display ' Use .Send to send directly
End With
' GoTo endFunction
End If
' Cleanup
Set rng = Nothing
Set TempWB = Nothing
Next cel
endFunction:
Application.StatusBar = False
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Sub Gen_Email_TwoPivotTable()
'This is for 2 tables
Dim pf1 As PivotField
Dim pf2 As PivotField
Dim pvtname As String
Dim lRow As Long
Dim cel As Range
Dim Pi As PivotItem
Dim OutApp As Object
Dim OutMail As Object
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng1 As Range
Dim rng2 As Range
Dim emailBody As String
Dim emailSignature As String
Dim rowCount As Long
Dim exportPath As String
Dim dateStr As String
Dim fileName As String
Dim TempWB As Workbook
Dim TempWS As Worksheet
Dim msg1 As String
Dim msg2 As String
Dim tfolder As String
Dim region1 As String
Dim tbl As String
Dim pvt1 As String
Dim pvt2 As String
' PivotTable names and sheet names
pvt1 = "PivotTable1"
pvt2 = "PivotTable1"
Set ws1 = Worksheets("Global_Super_Store") ' Adjust to the actual sheet name for PivotTable1
Set ws2 = Worksheets("Detailed Data") ' Adjust to the actual sheet name for PivotTable2
' Prepare messages
msg1 = "Hi Rushikesh, <br><br> Please find below the detailed sales summary " & _
"for the " & "<region>" & " region as requested. The report includes the latest figures and trends, highlighting key" & _
" insights that may be useful for our upcoming discussions.<br><br> Should you require any further information or " & _
"clarification, feel free to reach out."
' Get Outlook signature
emailSignature = GetOutlookSignature()
' Get Outlook application
On Error Resume Next
Set OutApp = GetObject(, "Outlook.Application")
If OutApp Is Nothing Then
Set OutApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0
' Clear all filters in PivotTable1 (ws1)
On Error Resume Next
For Each pf1 In ws1.PivotTables(pvt1).RowFields
pf1.ClearAllFilters
Next pf1
On Error GoTo 0
' Clear all filters in PivotTable2 (ws2)
On Error Resume Next
For Each pf2 In ws2.PivotTables(pvt2).RowFields
pf2.ClearAllFilters
Next pf2
On Error GoTo 0
ws1.Range("L:L").ClearContents
' Filter unique values for PivotTable1 (assume both PivotTables share the same region)
lRow = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
ws1.Range("A3:A" & lRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=ws1.Range("A3:A" & lRow), CopyToRange:=ws1.Range("L2"), Unique:=True
'ws1.Range("A3:A" & lRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws1.Range("L2"), Unique:=True
lRow = ws1.Range("L1048576").End(xlUp).Row - 1
Set pf1 = ws1.PivotTables(pvt1).PivotFields("Market")
Set pf2 = ws2.PivotTables(pvt2).PivotFields("Market")
dateStr = Format(Now(), "DDMMYYYY_HHMMSS")
' Loop through each unique value
For Each cel In ws1.Range("L3:L" & lRow)
' Filter PivotTable1 on ws1
pf1.ClearAllFilters
For Each Pi In pf1.PivotItems
Pi.Visible = (Pi.Name = cel.Value)
Next Pi
' Filter PivotTable2 on ws2 (if needed)
pf2.ClearAllFilters
For Each Pi In pf2.PivotItems
Pi.Visible = (Pi.Name = cel.Value)
Next Pi
' Get range for PivotTable1 (ws1)
lRow = ws1.Range("A1048576").End(xlUp).Row
Set rng1 = ws1.Range("A2:E" & lRow)
' Get range for PivotTable2 (ws2)
lRow = ws2.Range("A1048576").End(xlUp).Row
Set rng2 = ws2.Range("A2:E" & lRow)
' Prepare the email body
emailBody = "<html><body style='text-align: left;'>" & _
"<p style='font-family:Calibri; font-size:11pt; color:#000000; margin: 0;'>" & _
Replace(msg1, "<region>", cel.Value) & "<br>" & Replace(RangeToHTML(rng1), "align=center", "align=left") & "</p></body></html>"
' Create a new workbook
Set TempWB = Workbooks.Add
Set TempWS = TempWB.Sheets(1)
' Copy the filtered range to the new workbook
rng2.Copy
TempWS.Range("A1").PasteSpecial Paste:=xlPasteValues
TempWS.Range("A1").PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
' Generate the file name and save the new workbook
fileName = cel.Value & "_" & dateStr & ".xlsx"
exportPath = "C:\Users\Ajeet Prasad\Downloads\" & fileName
Application.DisplayAlerts = False
TempWB.SaveAs fileName:=exportPath, FileFormat:=xlOpenXMLWorkbook
TempWB.Close SaveChanges:=False
Application.DisplayAlerts = True
' Prepare email with the file attached
' emailBody = "<html><body style='text-align: left;'>" & _
' "<p style='font-family:Calibri; font-size:11pt; color:#000000; margin: 0;'>" & _
' Replace(msg1, "<region>", cel.Value) & "<br>" & RangeToHTML(rng1) & "</p></body></html>"
' Create and send the email with attachment
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = "recipient@example.com" ' Change this to the recipient's email
.Subject = "Filtered Data: " & cel.Value
.HTMLBody = emailBody & emailSignature
.Attachments.Add exportPath
.Display ' Use
' .Send 'to send directly
End With
' Cleanup
Set rng1 = Nothing
Set rng2 = Nothing
Next cel
endFunction:
Application.StatusBar = False
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function RangeToHTML(rng As Range) As String
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
' Copy range to a temporary workbook
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1, 1).PasteSpecial Paste:=8 ' A1
.Cells(1, 1).PasteSpecial Paste:=xlPasteValues ' A1
.Cells(1, 1).PasteSpecial Paste:=xlPasteFormats 'A1
Application.CutCopyMode = False
End With
' Publish the sheet to an HTML file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
fileName:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, HtmlType:=xlHtmlStatic)
.Publish (True)
End With
' Read the HTML file back as a string
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangeToHTML = ts.ReadAll
ts.Close
' Clean up
TempWB.Close SaveChanges:=False
Kill TempFile
End Function
' Function to get the default Outlook signature
Function GetOutlookSignature() As String
Dim fso As Object
Dim ts As Object
Dim sigFile As String
Dim sigPath As String
sigPath = Environ("appdata") & "\Microsoft\Signatures\"
sigFile = Dir(sigPath & "*.htm")
If sigFile <> "" Then
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.OpenTextFile(sigPath & sigFile, 1, False)
GetOutlookSignature = ts.ReadAll
ts.Close
Else
GetOutlookSignature = ""
End If
End Function
Sub SetSensitivityLabelExcel()
Dim wb As Workbook
Set wb = ActiveWorkbook
' Check if workbook supports sensitivity labels
If wb.SensitivityLabelPolicy.Count > 0 Then
' Assign the first available sensitivity label
Dim sensitivityLabel As Office.SensitivityLabel
Set sensitivityLabel = wb.SensitivityLabelPolicy.Labels(1) ' Set to the first label
' Apply the label to the workbook
wb.SensitivityLabelPolicy.ApplyLabel sensitivityLabel
MsgBox "Label '" & sensitivityLabel.Name & "' applied to workbook."
Else
MsgBox "No sensitivity labels available for this workbook."
End If
' Save the workbook
wb.Save
MsgBox "Workbook saved with sensitivity label."
End Sub
Sub RetrieveSensitivityLabelInfoExcel()
Dim wb As Workbook
Set wb = ActiveWorkbook
' Check if the workbook has a sensitivity label
If Not wb.SensitivityLabel Is Nothing Then
MsgBox "Current sensitivity label: " & wb.SensitivityLabel.Name
Else
MsgBox "No sensitivity label applied to this workbook."
End If
End Sub
'Combine code and resolve the error.
Public uMsg As String
Sub CommandButton1_Click()
Dim OutApp As Object
Dim OutMail As Object
Dim pt As PivotTable
Dim pf As PivotField
Dim pf2 As PivotField
Dim pvt As String
Dim pvt2 As String
Dim pvtname As String
Dim pi As PivotItem
Dim lRow As Long
Dim rowCount As Long
Dim cel As Range
Dim wb As Workbook
Dim TempWB As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim TempWS As Worksheet
Dim rng As Range
Dim rng2 As Range
Dim selectedCell As Range
Dim emailBody As String
Dim emailSignature As String
Dim exportPath As String
Dim dateStr As String
Dim fileName As String
Dim msg1 As String
Dim msg2 As String
Dim tfolder As String
Dim region1 As String
Dim tbl As String
uMsg = ""
'Validation
If optTable1 = False And optTable2 = False Then
uMsg = "Please Select 1 of the option"
GoTo endfunction
End If
' Prepare messages
msg1 = ThisWorkbook.Worksheets("Admin").Range("C2").Value
msg2 = ThisWorkbook.Worksheets("Admin").Range("C3").Value
On Error Resume Next
' Prompt user to select a cell using an InputBox
Set selectedCell = Application.InputBox("Please Select a cell inside a PivotTable", Type:=8)
' Check if the selection is valid
If selectedCell Is Nothing Then
uMsg = "No cell selected. Exiting."
GoTo endfunction
End If
' Check if the selected cell is inside a PivotTable
If selectedCell.PivotTable Is Nothing Then
uMsg = "The selected cell Is Not inside a PivotTable."
GoTo endfunction
End If
On Error GoTo 0
' Set references to the PivotTable, Worksheet, and Workbook
Set pt = selectedCell.PivotTable
Set ws = pt.Parent
'Set wb = ws.Parent
pvtname = pt.Name
If optTable2 = True Then
' Prompt user to select a cell using an InputBox
Set selectedCell = Application.InputBox("Please Select a cell inside a PivotTable2", Type:=8)
' Check if the selection is valid
If selectedCell Is Nothing Then
uMsg = "No cell selected. Exiting."
GoTo endfunction
End If
On Error Resume Next
' Check if the selected cell is inside a PivotTable
If selectedCell.PivotTable Is Nothing Then
uMsg = "The selected cell Is Not inside a PivotTable."
GoTo endfunction
End If
On Error GoTo 0
End If
' Set references to the PivotTable, Worksheet, and Workbook
Set pt = selectedCell.PivotTable
Set ws2 = pt.Parent
pvtname2 = pt.Name
tfolder = Environ("TEMP")
dateStr = Format(Now(), "DDMMYYYY_HHMMSS")
'Get default signature
emailSignature = GetOutlookSignature()
' Get Outlook application
On Error Resume Next
Set OutApp = GetObject(, "Outlook.Application")
If OutApp Is Nothing Then
Set OutApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0
If optTable1 = True Then
Application.StatusBar = "Start"
' Clear all filters in pivot
On Error Resume Next
For Each pf In ws.PivotTables(pvtname).RowFields
pf.ClearAllFilters
Next pf
On Error GoTo 0
' Find unique values
ws.Range("L:L").ClearContents
lRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
ws.Range("A3:A" & lRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=ws.Range("A3:A" & lRow), CopyToRange:=ws.Range("L2"), Unique:=True
lRow = ws.Range("L1048576").End(xlUp).Row
Set pf = ws.PivotTables(pvtname).PivotFields("Market")
' Loop through each unique value
For Each cel In ws.Range("L3:L" & lRow)
pf.ClearAllFilters
' Set PivotItem visibility
For Each pi In pf.PivotItems
pi.Visible = (pi.Name = cel.Value)
Next pi
' Get the range of data to copy
lRow = ws.Range("A1048576").End(xlUp).Row
Set rng = ws.Range("A2:E" & lRow)
' Count number of rows
rowCount = rng.Rows.Count
' If data has 20 or fewer rows, send it via email
If rowCount <= 20 Then
'Prepare email body in HTML format
emailBody = "<html><body 'text-align: left;'>" & _
"<p 'font-family:Calibri; font-size:11pt; color:#000000; margin: 0;'>" & _
Replace(msg1, "<region>", cel.Value) & "<br>" & Replace(RangeToHTML(rng), "align=center", "align=left") & "</p></body></html>"
' Create and send the email
Set OutMail = OutApp.CreateItem(0)
With OutMail
.Display
.to = "recipient@example.com" ' Change this to the recipient's email
.Subject = "Filtered Data: " & cel.Value
.HTMLBody = emailBody & emailSignature
End With
' If data has more than 20 rows, export it to a new Excel file
ElseIf rowCount > 20 Then
' Create a new workbook
Set TempWB = Workbooks.Add
Set TempWS = TempWB.Sheets(1)
' Copy the filtered range to the new workbook
rng.Copy
TempWS.Range("A1").PasteSpecial Paste:=xlPasteValues
TempWS.Range("A1").PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
' Generate the file name and save the new workbook
fileName = cel.Value & "_" & dateStr & ".xlsx"
exportPath = tfolder & "\" & fileName
TempWB.SaveAs fileName:=exportPath, FileFormat:=xlOpenXMLWorkbook
TempWB.Close SaveChanges:=False
' Prepare email with the file attached
emailBody = "<html><body 'text-align: left;'>" & _
"<p 'font-family:Calibri; font-size:11pt; color:#000000; margin: 0;'>" & _
Replace(msg2, "<region>", cel.Value) & "<br>" & RangeToHTML(rng) & "</p></body></html>"
' Create and send the email with attachment
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = "recipient@example.com" ' Change this to the recipient's email
.Subject = "Filtered Data: " & cel.Value
.HTMLBody = emailBody & emailSignature
.Attachments.Add exportPath
.Display
End With
End If
Next cel
ElseIf optTable2 = True Then
' Clear all filters in PivotTable1 (ws)
On Error Resume Next
For Each pf In ws.PivotTables(pvtname).RowFields
pf.ClearAllFilters
Next pf
On Error GoTo 0
' Clear all filters in PivotTable2 (ws2)
On Error Resume Next
For Each pf2 In ws2.PivotTables(pvtname2).RowFields
pf2.ClearAllFilters
Next pf2
On Error GoTo 0
ws.Range("L:L").ClearContents
' Filter unique values for PivotTable1 (assume both PivotTables share the same region)
lRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
ws.Range("A3:A" & lRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=ws.Range("A3:A" & lRow), CopyToRange:=ws.Range("L2"), Unique:=True
lRow = ws.Range("L1048576").End(xlUp).Row - 1
Set pf = ws.PivotTables(pvtname).PivotFields("Market")
Set pf2 = ws2.PivotTables(pvtname2).PivotFields("Market")
' Loop through each unique value
For Each cel In ws.Range("L3:L" & lRow)
' Filter PivotTable1 on ws
pf.ClearAllFilters
For Each pi In pf.PivotItems
pi.Visible = (pi.Name = cel.Value)
Next pi
' Filter PivotTable2 on ws2 (if needed)
pf2.ClearAllFilters
For Each pi In pf2.PivotItems
pi.Visible = (pi.Name = cel.Value)
Next pi
' Get range for PivotTable1 (ws)
lRow = ws.Range("A1048576").End(xlUp).Row
Set rng = ws.Range("A2:E" & lRow)
' Get range for PivotTable2 (ws2)
lRow = ws2.Range("A1048576").End(xlUp).Row
Set rng2 = ws2.Range("A2:E" & lRow)
' Prepare the email body
emailBody = "<html><body 'text-align: left;'>" & _
"<p 'font-family:Calibri; font-size:11pt; color:#000000; margin: 0;'>" & _
Replace(msg1, "<region>", cel.Value) & "<br>" & Replace(RangeToHTML(rng), "align=center", "align=left") & "</p></body></html>"
' Create a new workbook
Set TempWB = Workbooks.Add
Set TempWS = TempWB.Sheets(1)
' Copy the filtered range to the new workbook
rng2.Copy
TempWS.Range("A1").PasteSpecial Paste:=xlPasteValues
TempWS.Range("A1").PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
' Generate the file name and save the new workbook
fileName = cel.Value & "_" & dateStr & ".xlsx"
exportPath = myDownloadPath & "\" & fileName
Application.DisplayAlerts = False
TempWB.SaveAs fileName:=exportPath, FileFormat:=xlOpenXMLWorkbook
TempWB.Close SaveChanges:=False
Application.DisplayAlerts = True
' Create and send the email with attachment
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = "recipient@example.com" ' Change this to the recipient's email
.Subject = "Filtered Data: " & cel.Value
.HTMLBody = emailBody & emailSignature
.Attachments.Add exportPath
.Display
End With
Next cel
End If
endfunction:
Application.StatusBar = False
Set OutMail = Nothing
Set OutApp = Nothing
Set TempWB = Nothing
Set TempWS = Nothing
Set ws = Nothing
Set ws2 = Nothing
Set pf = Nothing
Set pf2 = Nothing
Set pi = Nothing
Set rng = Nothing
Set rng = Nothing
Set rng2 = Nothing
Set pf = Nothing
Set cel = Nothing
If uMsg <> "" Then MsgBox uMsg
'SheetError:
' MsgBox "One or both of the sheets were not found. Please check the sheet names.", vbCritical
End Sub
