Different pivot tables to different emails vba - vba

Question

I have multiple pivot tables that I want to send out individually to different emails. The problem is, the email keeps getting written over by the second email. Each pivot table is named different and the code works fine with only one reference. I have tried multiple ways to get it but cant. Can someone help?
Private Sub Workbook_Open()
Dim wk As Worksheet
Dim wk1 As Worksheet
wk = Worksheets("EPSICAR")
wk.Connections("owssvr").Refresh
wk1 = Worksheets("PastDue")
wk1.RefreshAll
End Sub
Sub pastdue()
Dim myApp As Outlook.Application, mymail As Outlook.Mailitem
Dim Lap As Object
Dim rng As Range
Dim rngmtl As Range
Dim Mailitem As Object
Set myApp = New Outlook.Application
Set mymail = myApp.CreateItem(olMailItem)
Set rng = Sheets("PastDue").PivotTables("Q Group Past
Due").TableRange1
Set rngmtl = Sheets("PastDue").PivotTables("Mtl Group Past
Due").TableRange2
With mymail
.To = "sponge.bobh#12345.com"
.CC = "pat.star#12345.com"
.Subject = "ICAR/EPS past due"
.HTMLBody = "The following are a list of ICARs/EPS that are past due" &
RangetoHTML(rng)
.Display
'.send
With mymail
.To = "blue.berry#12345.com"
.CC = "black.berry#12345.com"
.Subject = "ICAR/EPS past due"
.HTMLBody = "The following are a list of ICARs/EPS that are past due" &
RangetoHTML(rngmtl)
.Display
'.send
Set myApp = Nothing
Set mymail = Nothing
End With
End With
End Sub
Function RangetoHTML(rng As Range)
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"
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
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
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
TempWB.Close savechanges:=False
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function

Answer 1

I think your approach is off a bit. I suppose there are a few ways to do this kind of thing. You can refresh the pivot multiple ways, and email a snapshot of each to different recipients. You could refresh the pivot multiple ways, save each, and email the saved version of each to separate people. If you want to go down this path, try to code sample below.
Make a list in Sheets("Sheet1") with :
In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)
The Macro will loop through each row in "Sheet1" and if there is a E-mail address in column B
and file name(s) in column C:Z it will create a mail with this information and send it.
Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Send 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
There are probably a couple other approaches you could consider. Just get one thing to work, before trying a different means to the same end.