How to write Macro for exporting PIVOT tab to PPT

[gargi_bardhan]

Hello everyone,

Can anyone help me how to export a pivot table into PPT, I hav done couple of permutations with the macro for exporting charts & its working only for pie charts but not with pivot table.

The code follows like this:

sub sendToPPT()
Set PPApp = CreateObject("Powerpoint.Application")
fname=InputBox("Enter FileName","SaveAs","MyPresentation")
PPApp.Visible = True ' Create a presentation

Set PPPres = PPApp.Presentations.Add
set s=ActiveDocument.Sheets("Sheet2")
charts=s.GetGraphs
Set PPSlide = PPPres.Slides.Add(1, 1)
PPSlide.Shapes(1).Delete ' removes the title
PPSlide.Shapes(1).Delete ' removes the text box
vPosition=50
for i=lbound(charts) to ubound(charts)
Set PPSlide = PPPres.Slides.Add(1,1)
'PPSlide.Shapes(1).Delete ' removes the title
'PPSlide.Shapes(1).Delete ' removes the text box
msgbox(charts(i).getobjectid)
ActiveDocument.GetSheetObject(charts(i).getobjectid).CopyBitmapToClipboard
PPSlide.Shapes.Paste.Select
PPApp.ActiveWindow.Selection.ShapeRange.Left = 10
PPApp.ActiveWindow.Selection.ShapeRange.Top = vPosition
vPosition = vPosition + 10
next
PPPres.SaveAs "D:\QlikView\DATABASE\CDR\Applications"&fname&".ppt"
' PPPres.Close
PPPres.Close
PPApp.Quit
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
end sub

--

Best Regards,

Gargi

[manojkvrajan]

Hi Gargi,

Did you figure out a solution for this? If yes, can you share in the forum?

Thanks,

Manoj

[gargi_bardhan]

Hi Manoj,

Try this:

sub ppt1
Set PPApp = CreateObject("Powerpoint.Application")
PPApp.Visible = True ' Create a presentation
Set PPPres = PPApp.Presentations.Add

set s=ActiveDocument.Sheets("Sheet1") /// name of your Sheet
'charts=s.GetGraphs
charts=s.GetSheetObjects
for i=lbound(charts) to ubound(charts)
if(UCASE(mid(charts(i).getobjectid,10,2)))="CH" then
Set PPSlide = PPPres.Slides.Add(1, 1)
PPSlide.Shapes(1).Delete ' removes the title
PPSlide.Shapes(1).Delete ' removes the text box
ActiveDocument.GetSheetObject(charts(i).getobjectid).CopyBitmapToClipboard
PPSlide.Shapes.Paste
end if
next

PPPres.SaveAs "C:\Temp\MyPresentationSheet1.ppt" ////// Location u want to save the PPT
PPPres.Close
PPApp.Quit
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
end sub