I found a wonderful resource @ http://www.rondebruin.nl for macros. I have been doing trail and error. This is a very frustrating experience.
<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com
fficeffice" /><o
> </o>
What I am attempting to email two pivot charts in the same email. I have been able to get one pivot chart to be copied correctly; however I am not able to get the other pivot chart to copy. Instead it copies the rest of the worksheet and emails the document.
<o> </o>
I would like to have it where one chart is above the other.
<o> </o>
Thank you for any help you can provide
<o> </o>
<o> </o>
Sub EmailMissingImages()<o></o>
Dim rng As Range<o></o>
Dim rng1 As Range<o></o>
Dim rng2 As Range<o></o>
Dim OutApp As Object<o></o>
Dim OutMail As Object<o></o>
<o> </o>
Set rng = Nothing<o></o>
On Error Resume Next<o></o>
<o></o>
Set rng1 = Selection.SpecialCells(xlCellTypeVisible)<o></o>
<o></o>
Set rng1 = Range("AQ3").Select<o></o>
ActiveSheet.PivotTables("Missing Image Count").PivotSelect "", xlDataAndLabel, True<o></o>
On Error GoTo 0<o></o>
<o></o>
Set rng = Nothing<o></o>
On Error Resume Next<o></o>
Set rng2 = Selection.SpecialCells(xlCellTypeVisible)<o></o>
Set rng2 = Range("N6").Select<o></o>
ActiveSheet.PivotTables("Missing Image Data").PivotSelect "", xlDataAndLabel, True<o></o>
On Error GoTo 0<o></o>
<o> </o>
If rng2 Is Nothing Then<o></o>
MsgBox "The selection is not a range or the sheet is protected" & _<o></o>
vbNewLine & "please correct and try again.", vbOKOnly<o></o>
Exit Sub<o></o>
End If<o></o>
<o> </o>
With Application<o></o>
.EnableEvents = False<o></o>
.ScreenUpdating = False<o></o>
End With<o></o>
<o> </o>
Set OutApp = CreateObject("Outlook.Application")<o></o>
Set OutMail = OutApp.CreateItem(0)<o></o>
<o> </o>
On Error Resume Next<o></o>
With OutMail<o></o>
.To ThisWorkbook.Sheets("Email to").Range("b2").Value<o></o>
.CC = ThisWorkbook.Sheets("Email to").Range("c2").Value<o></o>
.BCC = ""<o></o>
.Subject = "This is the Subject line"<o></o>
.HTMLBody = RangetoHTML(rng2) & RangetoHTML(rng1)<o></o>
.Send 'or use .Display<o></o>
End With<o></o>
On Error GoTo 0<o></o>
<o> </o>
With Application<o></o>
.EnableEvents = True<o></o>
.ScreenUpdating = True<o></o>
End With<o></o>
<o> </o>
Set OutMail = Nothing<o></o>
Set OutApp = Nothing<o></o>
End Sub<o></o>
Function RangetoHTML(rng As Range)<o></o>
Dim fso As Object<o></o>
Dim ts As Object<o></o>
Dim TempFile As String<o></o>
Dim TempWB As Workbook<o></o>
<o></o>
TempFileName = ThisWorkbook.Sheets("Final Output").Range("N1").Value<o></o>
<o></o>
'Copy the range and create a new workbook to past the data in<o></o>
rng.Copy<o></o>
Set TempWB = Workbooks.Add(1)<o></o>
With TempWB.Sheets(1)<o></o>
.Cells(1).PasteSpecial Paste:=8<o></o>
.Cells(1).PasteSpecial xlPasteValues, , False, False<o></o>
.Cells(1).PasteSpecial xlPasteFormats, , False, False<o></o>
.Cells(1).Select<o></o>
Application.CutCopyMode = False<o></o>
On Error Resume Next<o></o>
.DrawingObjects.Visible = True<o></o>
.DrawingObjects.Delete<o></o>
On Error GoTo 0<o></o>
End With<o></o>
<o></o>
With TempWB.PublishObjects.Add( _<o></o>
SourceType:=xlSourceRange, _<o></o>
Filename:=TempFile, _<o></o>
Sheet:=TempWB.Sheets(1).Name, _<o></o>
Source:=TempWB.Sheets(1).UsedRange.Address, _<o></o>
HtmlType:=xlHtmlStatic)<o></o>
.Publish (True)<o></o>
End With<o></o>
<o></o>
Set fso = CreateObject("Scripting.FileSystemObject")<o></o>
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)<o></o>
RangetoHTML = ts.ReadAll<o></o>
ts.Close<o></o>
RangetoHTML = Replace(RangetoHTML, "align=center xublishsource=", _<o></o>
"align=left xublishsource=")<o></o>
<o></o>
TempWB.Close savechanges:=False<o></o>
<o></o>
Kill TempFile<o></o>
<o></o>
Set ts = Nothing<o></o>
Set fso = Nothing<o></o>
Set TempWB = Nothing<o></o>
End Function<o></o>
<o> </o>
Private Sub CommandButton1_Click()<o></o>
Dim PT As PivotTable<o></o>
Dim WS As Worksheet<o></o>
<o></o>
For Each WS In ThisWorkbook.Worksheets<o></o>
<o></o>
For Each PT In WS.PivotTables<o></o>
PT.RefreshTable<o></o>
Next PT<o></o>
<o></o>
Next WS<o></o>
End Sub
<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com
fficeffice" /><o> </o>What I am attempting to email two pivot charts in the same email. I have been able to get one pivot chart to be copied correctly; however I am not able to get the other pivot chart to copy. Instead it copies the rest of the worksheet and emails the document.
<o
> </o>I would like to have it where one chart is above the other.
<o
> </o>Thank you for any help you can provide
<o
> </o><o
> </o>Sub EmailMissingImages()<o
></o>Dim rng As Range<o
></o>Dim rng1 As Range<o
></o>Dim rng2 As Range<o
></o>Dim OutApp As Object<o
></o>Dim OutMail As Object<o
></o><o
> </o>Set rng = Nothing<o
></o>On Error Resume Next<o
></o><o
></o>Set rng1 = Selection.SpecialCells(xlCellTypeVisible)<o
></o><o
></o>Set rng1 = Range("AQ3").Select<o
></o>ActiveSheet.PivotTables("Missing Image Count").PivotSelect "", xlDataAndLabel, True<o
></o>On Error GoTo 0<o
></o><o
></o>Set rng = Nothing<o
></o>On Error Resume Next<o
></o>Set rng2 = Selection.SpecialCells(xlCellTypeVisible)<o
></o>Set rng2 = Range("N6").Select<o
></o>ActiveSheet.PivotTables("Missing Image Data").PivotSelect "", xlDataAndLabel, True<o
></o>On Error GoTo 0<o
></o><o
> </o>If rng2 Is Nothing Then<o
></o>MsgBox "The selection is not a range or the sheet is protected" & _<o
></o>vbNewLine & "please correct and try again.", vbOKOnly<o
></o>Exit Sub<o
></o>End If<o
></o><o
> </o>With Application<o
></o>.EnableEvents = False<o
></o>.ScreenUpdating = False<o
></o>End With<o
></o><o
> </o>Set OutApp = CreateObject("Outlook.Application")<o
></o>Set OutMail = OutApp.CreateItem(0)<o
></o><o
> </o>On Error Resume Next<o
></o>With OutMail<o
></o>.To ThisWorkbook.Sheets("Email to").Range("b2").Value<o
></o>.CC = ThisWorkbook.Sheets("Email to").Range("c2").Value<o
></o>.BCC = ""<o
></o>.Subject = "This is the Subject line"<o
></o>.HTMLBody = RangetoHTML(rng2) & RangetoHTML(rng1)<o
></o>.Send 'or use .Display<o
></o>End With<o
></o>On Error GoTo 0<o
></o><o
> </o>With Application<o
></o>.EnableEvents = True<o
></o>.ScreenUpdating = True<o
></o>End With<o
></o><o
> </o>Set OutMail = Nothing<o
></o>Set OutApp = Nothing<o
></o>End Sub<o
></o>Function RangetoHTML(rng As Range)<o
></o>Dim fso As Object<o
></o>Dim ts As Object<o
></o>Dim TempFile As String<o
></o>Dim TempWB As Workbook<o
></o><o
></o>TempFileName = ThisWorkbook.Sheets("Final Output").Range("N1").Value<o
></o><o
></o>'Copy the range and create a new workbook to past the data in<o
></o>rng.Copy<o
></o>Set TempWB = Workbooks.Add(1)<o
></o>With TempWB.Sheets(1)<o
></o>.Cells(1).PasteSpecial Paste:=8<o
></o>.Cells(1).PasteSpecial xlPasteValues, , False, False<o
></o>.Cells(1).PasteSpecial xlPasteFormats, , False, False<o
></o>.Cells(1).Select<o
></o>Application.CutCopyMode = False<o
></o>On Error Resume Next<o
></o>.DrawingObjects.Visible = True<o
></o>.DrawingObjects.Delete<o
></o>On Error GoTo 0<o
></o>End With<o
></o><o
></o>With TempWB.PublishObjects.Add( _<o
></o>SourceType:=xlSourceRange, _<o
></o>Filename:=TempFile, _<o
></o>Sheet:=TempWB.Sheets(1).Name, _<o
></o>Source:=TempWB.Sheets(1).UsedRange.Address, _<o
></o>HtmlType:=xlHtmlStatic)<o
></o>.Publish (True)<o
></o>End With<o
></o><o
></o>Set fso = CreateObject("Scripting.FileSystemObject")<o
></o>Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)<o
></o>RangetoHTML = ts.ReadAll<o
></o>ts.Close<o
></o>RangetoHTML = Replace(RangetoHTML, "align=center x
ublishsource=", _<o></o>"align=left x
ublishsource=")<o></o><o
></o>TempWB.Close savechanges:=False<o
></o><o
></o>Kill TempFile<o
></o><o
></o>Set ts = Nothing<o
></o>Set fso = Nothing<o
></o>Set TempWB = Nothing<o
></o>End Function<o
></o><o
> </o>Private Sub CommandButton1_Click()<o
></o>Dim PT As PivotTable<o
></o>Dim WS As Worksheet<o
></o><o
></o>For Each WS In ThisWorkbook.Worksheets<o
></o><o
></o>For Each PT In WS.PivotTables<o
></o>PT.RefreshTable<o
></o>Next PT<o
></o><o
></o>Next WS<o
></o>End Sub
