SOLVED
Home

Excel charts to Powerpoint exporting using VBA

%3CLINGO-SUB%20id%3D%22lingo-sub-310197%22%20slang%3D%22en-US%22%3EExcel%20charts%20to%20Powerpoint%20exporting%20using%20VBA%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-310197%22%20slang%3D%22en-US%22%3E%3CP%3EHi%2C%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3ECan%20anyone%20share%20a%20code%20which%20can%20be%20used%20to%20copy%20and%20paste%20all%20the%20charts%20from%20a%20workbook%20to%20a%20powerpoint%20presenatation.%20Have%20about%2095%20different%20charts%20on%20different%20sheets%20in%20the%20workbook.%20Have%20searched%20for%20a%20macro%20but%20none%20has%20worked%20for%20me.%3C%2FP%3E%3CP%3EIf%20anyone%20can%20share%20a%20code%20that%20can%20export%20all%20the%20charts%20it%20would%20really%20help%20me%20save%20my%20work.%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3ERegards%2C%3C%2FP%3E%3CP%3EAditya%26nbsp%3B%3C%2FP%3E%3C%2FLINGO-BODY%3E%3CLINGO-LABS%20id%3D%22lingo-labs-310197%22%20slang%3D%22en-US%22%3E%3CLINGO-LABEL%3EExcel%3C%2FLINGO-LABEL%3E%3CLINGO-LABEL%3EMacros%20and%20VBA%3C%2FLINGO-LABEL%3E%3C%2FLINGO-LABS%3E%3CLINGO-SUB%20id%3D%22lingo-sub-320056%22%20slang%3D%22en-US%22%3ERe%3A%20Excel%20charts%20to%20Powerpoint%20exporting%20using%20VBA%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-320056%22%20slang%3D%22en-US%22%3E%3CP%3EHi%20Kinuasa%2C%3C%2FP%3E%3CP%3EThis%20code%20worked%20very%20well%20and%20it%20did%20wonders%20for%20me.%3C%2FP%3E%3CP%3EThank%20you%20so%20much%20for%20providing%20me%20with%20the%20solution.%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3ERegards%2C%3C%2FP%3E%3CP%3EAditya%3C%2FP%3E%3C%2FLINGO-BODY%3E%3CLINGO-SUB%20id%3D%22lingo-sub-314962%22%20slang%3D%22en-US%22%3ERe%3A%20Excel%20charts%20to%20Powerpoint%20exporting%20using%20VBA%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-314962%22%20slang%3D%22en-US%22%3E%3CP%3EHi%2C%3CBR%20%2F%3Eplease%20try%20the%20sample%20code%20below%3A%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3EPublic%20Sub%20ChartsToPpt()%3CBR%20%2F%3E%26nbsp%3B%20Dim%20sht%20As%20Object%3CBR%20%2F%3E%26nbsp%3B%20Dim%20cht%20As%20Excel.ChartObject%3CBR%20%2F%3E%26nbsp%3B%20Dim%20appPpt%20As%20Object%20'PowerPoint.Application%3CBR%20%2F%3E%26nbsp%3B%20Dim%20prs%20As%20Object%20'PowerPoint.Presentation%3CBR%20%2F%3E%26nbsp%3B%3CBR%20%2F%3E%26nbsp%3B%20'Create%20New%20Presentation%3CBR%20%2F%3E%26nbsp%3B%20Set%20appPpt%20%3D%20CreateObject(%22PowerPoint.Application%22)%3CBR%20%2F%3E%26nbsp%3B%20appPpt.Visible%20%3D%20msoTrue%3CBR%20%2F%3E%26nbsp%3B%20Set%20prs%20%3D%20appPpt.Presentations.Add(msoTrue)%3CBR%20%2F%3E%26nbsp%3B%3CBR%20%2F%3E%26nbsp%3B%20For%20Each%20sht%20In%20ActiveWorkbook.Sheets%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%20If%20sht.Visible%20%3D%20xlSheetVisible%20Then%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%20sht.Select%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%20Select%20Case%20LCase(TypeName(sht))%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%20Case%20%22worksheet%22%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%20For%20Each%20cht%20In%20sht.ChartObjects%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%20cht.Select%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%20Application.CommandBars.ExecuteMso%20%22Copy%22%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%20PasteChart%20appPpt%2C%20prs%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%20Next%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%20Case%20%22chart%22%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%20Application.CommandBars.ExecuteMso%20%22Copy%22%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%20PasteChart%20appPpt%2C%20prs%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%20End%20Select%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%20End%20If%3CBR%20%2F%3E%26nbsp%3B%20Next%3CBR%20%2F%3EEnd%20Sub%3CBR%20%2F%3E%3CBR%20%2F%3EPrivate%20Sub%20PasteChart(ByVal%20PowerPointApplication%20As%20Object%2C%20_%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%20ByVal%20TargetPresentation%20As%20Object)%3CBR%20%2F%3E%26nbsp%3B%20Dim%20sld%20As%20Object%20'PowerPoint.Slide%3CBR%20%2F%3E%26nbsp%3B%20Dim%20cnt%20As%20Long%3CBR%20%2F%3E%26nbsp%3B%20Const%20ppLayoutBlank%20%3D%2012%3CBR%20%2F%3E%26nbsp%3B%3CBR%20%2F%3E%26nbsp%3B%20Set%20sld%20%3D%20TargetPresentation.Slides.Add(%20_%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%20TargetPresentation.Slides.Count%20%2B%201%2C%20ppLayoutBlank)%20'Add%20New%20Slide%3CBR%20%2F%3E%26nbsp%3B%20sld.Select%3CBR%20%2F%3E%26nbsp%3B%20cnt%20%3D%20sld.Shapes.Count%3CBR%20%2F%3E%26nbsp%3B%3CBR%20%2F%3E%26nbsp%3B%20PowerPointApplication.CommandBars.ExecuteMso%20%22PasteExcelChartSourceFormatting%22%3CBR%20%2F%3E%26nbsp%3B%20Do%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%20DoEvents%3CBR%20%2F%3E%26nbsp%3B%20Loop%20Until%20cnt%20%26lt%3B%26gt%3B%20sld.Shapes.Count%3CBR%20%2F%3EEnd%20Sub%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3E-------------%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3EPublic%20Sub%20ChartsToPptAsImage()%3CBR%20%2F%3E%26nbsp%3B%20Dim%20sht%20As%20Object%3CBR%20%2F%3E%26nbsp%3B%20Dim%20cht%20As%20Excel.ChartObject%3CBR%20%2F%3E%26nbsp%3B%20Dim%20appPpt%20As%20Object%20'PowerPoint.Application%3CBR%20%2F%3E%26nbsp%3B%20Dim%20prs%20As%20Object%20'PowerPoint.Presentation%3CBR%20%2F%3E%26nbsp%3B%3CBR%20%2F%3E%26nbsp%3B%20'Create%20New%20Presentation%3CBR%20%2F%3E%26nbsp%3B%20Set%20appPpt%20%3D%20CreateObject(%22PowerPoint.Application%22)%3CBR%20%2F%3E%26nbsp%3B%20appPpt.Visible%20%3D%20msoTrue%3CBR%20%2F%3E%26nbsp%3B%20Set%20prs%20%3D%20appPpt.Presentations.Add(msoTrue)%3CBR%20%2F%3E%26nbsp%3B%3CBR%20%2F%3E%26nbsp%3B%20For%20Each%20sht%20In%20ActiveWorkbook.Sheets%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%20If%20sht.Visible%20%3D%20xlSheetVisible%20Then%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%20Select%20Case%20LCase(TypeName(sht))%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%20Case%20%22worksheet%22%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%20For%20Each%20cht%20In%20sht.ChartObjects%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%20cht.CopyPicture%20Appearance%3A%3DxlScreen%2C%20_%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%20Format%3A%3DxlBitmap%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%20PasteChartImage%20prs%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%20Next%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%20Case%20%22chart%22%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%20sht.ChartArea.Copy%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%20PasteChartImage%20prs%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%26nbsp%3B%20End%20Select%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%20End%20If%3CBR%20%2F%3E%26nbsp%3B%20Next%3CBR%20%2F%3EEnd%20Sub%3CBR%20%2F%3E%3CBR%20%2F%3EPrivate%20Sub%20PasteChartImage(ByVal%20TargetPresentation%20As%20Object)%3CBR%20%2F%3E%26nbsp%3B%20Dim%20sld%20As%20Object%20'PowerPoint.Slide%3CBR%20%2F%3E%26nbsp%3B%20Const%20ppLayoutBlank%20%3D%2012%3CBR%20%2F%3E%26nbsp%3B%20Const%20ppPasteBitmap%20%3D%201%3CBR%20%2F%3E%26nbsp%3B%3CBR%20%2F%3E%26nbsp%3B%20Set%20sld%20%3D%20TargetPresentation.Slides.Add(%20_%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%20TargetPresentation.Slides.Count%20%2B%201%2C%20ppLayoutBlank)%20'Add%20New%20Slide%3CBR%20%2F%3E%26nbsp%3B%20With%20sld.Shapes.PasteSpecial(DataType%3A%3DppPasteBitmap%2C%20Link%3A%3DmsoFalse)%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%20.Align%20msoAlignCenters%2C%20True%3CBR%20%2F%3E%26nbsp%3B%26nbsp%3B%26nbsp%3B%20.Align%20msoAlignMiddles%2C%20True%3CBR%20%2F%3E%26nbsp%3B%20End%20With%3CBR%20%2F%3EEnd%20Sub%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3Ehope%20this%20helps.%3CBR%20%2F%3Ekinuasa%3C%2FP%3E%3C%2FLINGO-BODY%3E%3CLINGO-SUB%20id%3D%22lingo-sub-811900%22%20slang%3D%22en-US%22%3ERe%3A%20Excel%20charts%20to%20Powerpoint%20exporting%20using%20VBA%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-811900%22%20slang%3D%22en-US%22%3E%3CP%3E%3CA%20href%3D%22https%3A%2F%2Ftechcommunity.microsoft.com%2Ft5%2Fuser%2Fviewprofilepage%2Fuser-id%2F247409%22%20target%3D%22_blank%22%3E%40kinuasa%3C%2FA%3E%26nbsp%3B%20This%20is%20really%20helpful!%20Is%20there%20a%20way%20to%20get%20it%20to%20open%20a%20specific%20document%20instead%20of%20a%20new%20presentation%3FAlso%2C%20is%20there%20a%20way%20to%20make%20it%20paste%20special%20(Use%20Destination%20Theme%20%26amp%3B%20Link%20Data)%20for%20the%20charts%20(they%20are%20made%20the%20way%20I%20want%20them%20in%20excel%20and%20lose%20that%20when%20pasted%20into%20the%20ppt%2C%20currently)%3F%3C%2FP%3E%3C%2FLINGO-BODY%3E%3CLINGO-SUB%20id%3D%22lingo-sub-812300%22%20slang%3D%22en-US%22%3ERe%3A%20Excel%20charts%20to%20Powerpoint%20exporting%20using%20VBA%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-812300%22%20slang%3D%22en-US%22%3E%3CP%3E%3CA%20href%3D%22https%3A%2F%2Ftechcommunity.microsoft.com%2Ft5%2Fuser%2Fviewprofilepage%2Fuser-id%2F394807%22%20target%3D%22_blank%22%3E%40jstolme%3C%2FA%3E%26nbsp%3Bplease%20try%20below%20code%3A%3C%2FP%3E%3CPRE%20class%3D%22lia-code-sample%20language-csharp%22%3E%3CCODE%3EOption%20Explicit%0A%0APublic%20Sub%20ChartsToPpt()%0A%20%20Dim%20sht%20As%20Object%0A%20%20Dim%20cht%20As%20Excel.ChartObject%0A%20%20Dim%20appPpt%20As%20Object%20'PowerPoint.Application%0A%20%20Dim%20prs%20As%20Object%20'PowerPoint.Presentation%0A%20%20%0A%20%20Set%20appPpt%20%3D%20CreateObject(%22PowerPoint.Application%22)%0A%20%20appPpt.Visible%20%3D%20msoTrue%0A%20%20Set%20prs%20%3D%20appPpt.Presentations.Open(%22C%3A%5CTest%5CSample.pptx%22)%0A%20%20%0A%20%20For%20Each%20sht%20In%20ActiveWorkbook.Sheets%0A%20%20%20%20If%20sht.Visible%20%3D%20xlSheetVisible%20Then%0A%20%20%20%20%20%20sht.Select%0A%20%20%20%20%20%20Select%20Case%20LCase(TypeName(sht))%0A%20%20%20%20%20%20%20%20Case%20%22worksheet%22%0A%20%20%20%20%20%20%20%20%20%20For%20Each%20cht%20In%20sht.ChartObjects%0A%20%20%20%20%20%20%20%20%20%20%20%20cht.Select%0A%20%20%20%20%20%20%20%20%20%20%20%20Application.CommandBars.ExecuteMso%20%22Copy%22%0A%20%20%20%20%20%20%20%20%20%20%20%20PasteChart%20appPpt%2C%20prs%0A%20%20%20%20%20%20%20%20%20%20Next%0A%20%20%20%20%20%20%20%20Case%20%22chart%22%0A%20%20%20%20%20%20%20%20%20%20Application.CommandBars.ExecuteMso%20%22Copy%22%0A%20%20%20%20%20%20%20%20%20%20PasteChart%20appPpt%2C%20prs%0A%20%20%20%20%20%20End%20Select%0A%20%20%20%20End%20If%0A%20%20Next%0AEnd%20Sub%0A%0APrivate%20Sub%20PasteChart(ByVal%20PowerPointApplication%20As%20Object%2C%20_%0A%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20ByVal%20TargetPresentation%20As%20Object)%0A%20%20Dim%20sld%20As%20Object%20'PowerPoint.Slide%0A%20%20Dim%20cnt%20As%20Long%0A%20%20Const%20ppLayoutBlank%20%3D%2012%0A%20%20Const%20CtrlID1%20%3D%20%22PasteLinkedExcelChartDestinationTheme%22%0A%20%20Const%20CtrlID2%20%3D%20%22PasteExcelChartSourceFormatting%22%0A%20%20%0A%20%20Set%20sld%20%3D%20TargetPresentation.Slides.Add(%20_%0A%20%20%20%20TargetPresentation.Slides.Count%20%2B%201%2C%20ppLayoutBlank)%0A%20%20sld.Select%0A%20%20cnt%20%3D%20sld.Shapes.Count%0A%20%20With%20PowerPointApplication%0A%20%20%20%20If%20.CommandBars.GetEnabledMso(CtrlID1)%20%3D%20True%20Then%0A%20%20%20%20%20%20.CommandBars.ExecuteMso%20CtrlID1%0A%20%20%20%20Else%0A%20%20%20%20%20%20.CommandBars.ExecuteMso%20CtrlID2%0A%20%20%20%20End%20If%0A%20%20End%20With%0A%20%20Do%0A%20%20%20DoEvents%0A%20%20Loop%20Until%20cnt%20%26lt%3B%26gt%3B%20sld.Shapes.Count%0AEnd%20Sub%3C%2FCODE%3E%3C%2FPRE%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3C%2FLINGO-BODY%3E%3CLINGO-SUB%20id%3D%22lingo-sub-812941%22%20slang%3D%22en-US%22%3ERe%3A%20Excel%20charts%20to%20Powerpoint%20exporting%20using%20VBA%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-812941%22%20slang%3D%22en-US%22%3E%3CP%3E%3CA%20href%3D%22https%3A%2F%2Ftechcommunity.microsoft.com%2Ft5%2Fuser%2Fviewprofilepage%2Fuser-id%2F247409%22%20target%3D%22_blank%22%3E%40kinuasa%3C%2FA%3EThank%20you!%20This%20worked%20great.%20I%20made%20a%20small%20edit%20to%20make%20the%20new%20slides%20contain%20a%20title%20(Const%20ppLayoutTitleOnly%20%3D%2011).%26nbsp%3B%20The%20only%20thing%20I'm%20still%20trying%20to%20do%20is%20make%20the%20slide%20titles%20match%20the%20chart%20titles.%20I%20thought%20something%20like%20this%20may%20work%2C%20but%20I'm%20not%20sure%20where%20it%20would%20properly%20go%20or%20if%20it's%20appropriate%20given%20your%20approach.%20Thoughts%3F%3C%2FP%3E%3CPRE%3E'Copy%20and%20paste%20chart%20title%20as%20the%20slide%20title%20in%20PowerPoint%0A%20%20%20%20%20%20%20%20currentSlide.Shapes(1).TextFrame.TextRange.Text%20%3D%20cht.Chart.ChartTitle.Text%3C%2FPRE%3E%3CP%3E%26nbsp%3BMy%20current%20code%20is%3A%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CPRE%20class%3D%22lia-code-sample%20language-markup%22%3E%3CCODE%3EPublic%20Sub%20ChartsToPpt()%0A%20%20Dim%20sht%20As%20Object%0A%20%20Dim%20cht%20As%20Excel.ChartObject%0A%20%20Dim%20appPpt%20As%20Object%20'PowerPoint.Application%0A%20%20Dim%20prs%20As%20Object%20'PowerPoint.Presentation%0A%20%20%0A%20%20Set%20appPpt%20%3D%20CreateObject(%22PowerPoint.Application%22)%0A%20%20appPpt.Visible%20%3D%20msoTrue%0A%20%20Set%20prs%20%3D%20appPpt.Presentations.Open(%22C%3ASAMPLE%5CPATH%22)%0A%20%20%0A%20%20For%20Each%20sht%20In%20ActiveWorkbook.Sheets%0A%20%20%20%20If%20sht.Visible%20%3D%20xlSheetVisible%20Then%0A%20%20%20%20%20%20sht.Select%0A%20%20%20%20%20%20Select%20Case%20LCase(TypeName(sht))%0A%20%20%20%20%20%20%20%20Case%20%22worksheet%22%0A%20%20%20%20%20%20%20%20%20%20For%20Each%20cht%20In%20sht.ChartObjects%0A%20%20%20%20%20%20%20%20%20%20%20%20cht.Select%0A%20%20%20%20%20%20%20%20%20%20%20%20Application.CommandBars.ExecuteMso%20%22Copy%22%0A%20%20%20%20%20%20%20%20%20%20%20%20PasteChart%20appPpt%2C%20prs%0A%20%20%20%20%20%20%20%20%20%20Next%0A%20%20%20%20%20%20%20%20Case%20%22chart%22%0A%20%20%20%20%20%20%20%20%20%20Application.CommandBars.ExecuteMso%20%22Copy%22%0A%20%20%20%20%20%20%20%20%20%20PasteChart%20appPpt%2C%20prs%0A%20%20%20%20%20%20End%20Select%0A%20%20%20%20End%20If%0A%20%20Next%0AEnd%20Sub%0A%0APrivate%20Sub%20PasteChart(ByVal%20PowerPointApplication%20As%20Object%2C%20_%0A%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20ByVal%20TargetPresentation%20As%20Object)%0A%20%20Dim%20sld%20As%20Object%20'PowerPoint.Slide%0A%20%20Dim%20cnt%20As%20Long%0A%20%20Const%20ppLayoutTitleOnly%20%3D%2011%0A%20%20Const%20CtrlID1%20%3D%20%22PasteLinkedExcelChartDestinationTheme%22%0A%20%20Const%20CtrlID2%20%3D%20%22PasteExcelChartSourceFormatting%22%0A%20%20%0A%20%20Set%20sld%20%3D%20TargetPresentation.Slides.Add(%20_%0A%20%20%20%20TargetPresentation.Slides.Count%20%2B%201%2C%20ppLayoutTitleOnly)%0A%20%20sld.Select%0A%20%20cnt%20%3D%20sld.Shapes.Count%0A%20%20With%20PowerPointApplication%0A%20%20%20%20If%20.CommandBars.GetEnabledMso(CtrlID1)%20%3D%20True%20Then%0A%20%20%20%20%20%20.CommandBars.ExecuteMso%20CtrlID1%0A%20%20%20%20Else%0A%20%20%20%20%20%20.CommandBars.ExecuteMso%20CtrlID2%0A%20%20%20%20End%20If%0A%20%20End%20With%0A%20%20Do%0A%20%20%20DoEvents%0A%20%20Loop%20Until%20cnt%20%26lt%3B%26gt%3B%20sld.Shapes.Count%0AEnd%20Sub%3C%2FCODE%3E%3C%2FPRE%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3C%2FLINGO-BODY%3E%3CLINGO-SUB%20id%3D%22lingo-sub-816289%22%20slang%3D%22en-US%22%3ERe%3A%20Excel%20charts%20to%20Powerpoint%20exporting%20using%20VBA%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-816289%22%20slang%3D%22en-US%22%3E%3CP%3E%3CA%20href%3D%22https%3A%2F%2Ftechcommunity.microsoft.com%2Ft5%2Fuser%2Fviewprofilepage%2Fuser-id%2F394807%22%20target%3D%22_blank%22%3E%40jstolme%3C%2FA%3E%26nbsp%3BHi%2C%E3%80%80please%20try%20below%20code%3A%3C%2FP%3E%3CPRE%20class%3D%22lia-code-sample%20language-csharp%22%3E%3CCODE%3EOption%20Explicit%0A%0APublic%20Sub%20ChartsToPpt()%0A%20%20Dim%20sht%20As%20Object%0A%20%20Dim%20cht%20As%20Excel.ChartObject%0A%20%20Dim%20appPpt%20As%20Object%20'PowerPoint.Application%0A%20%20Dim%20prs%20As%20Object%20'PowerPoint.Presentation%0A%20%20Dim%20chtTitle%20As%20String%0A%20%20%0A%20%20Set%20appPpt%20%3D%20CreateObject(%22PowerPoint.Application%22)%0A%20%20appPpt.Visible%20%3D%20msoTrue%0A%20%20Set%20prs%20%3D%20appPpt.Presentations.Open(%22C%3A%5CTest%5CSample.pptx%22)%0A%20%20%0A%20%20For%20Each%20sht%20In%20ActiveWorkbook.Sheets%0A%20%20%20%20If%20sht.Visible%20%3D%20xlSheetVisible%20Then%0A%20%20%20%20%20%20sht.Select%0A%20%20%20%20%20%20Select%20Case%20LCase(TypeName(sht))%0A%20%20%20%20%20%20%20%20Case%20%22worksheet%22%0A%20%20%20%20%20%20%20%20%20%20For%20Each%20cht%20In%20sht.ChartObjects%0A%20%20%20%20%20%20%20%20%20%20%20%20If%20cht.Chart.HasTitle%20%3D%20True%20Then%20chtTitle%20%3D%20cht.Chart.ChartTitle.Text%0A%20%20%20%20%20%20%20%20%20%20%20%20cht.Select%0A%20%20%20%20%20%20%20%20%20%20%20%20Application.CommandBars.ExecuteMso%20%22Copy%22%0A%20%20%20%20%20%20%20%20%20%20%20%20PasteChart%20appPpt%2C%20prs%2C%20chtTitle%0A%20%20%20%20%20%20%20%20%20%20Next%0A%20%20%20%20%20%20%20%20Case%20%22chart%22%0A%20%20%20%20%20%20%20%20%20%20If%20sht.HasTitle%20%3D%20True%20Then%20chtTitle%20%3D%20sht.ChartTitle.Text%0A%20%20%20%20%20%20%20%20%20%20Application.CommandBars.ExecuteMso%20%22Copy%22%0A%20%20%20%20%20%20%20%20%20%20PasteChart%20appPpt%2C%20prs%2C%20chtTitle%0A%20%20%20%20%20%20End%20Select%0A%20%20%20%20End%20If%0A%20%20Next%0AEnd%20Sub%0A%0APrivate%20Sub%20PasteChart(ByVal%20PowerPointApplication%20As%20Object%2C%20_%0A%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20ByVal%20TargetPresentation%20As%20Object%2C%20_%0A%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20%20ByVal%20ChartTitle%20As%20String)%0A%20%20Dim%20sld%20As%20Object%20'PowerPoint.Slide%0A%20%20Dim%20cnt%20As%20Long%0A%20%20Const%20ppLayoutTitleOnly%20%3D%2011%0A%20%20Const%20CtrlID1%20%3D%20%22PasteLinkedExcelChartDestinationTheme%22%0A%20%20Const%20CtrlID2%20%3D%20%22PasteExcelChartSourceFormatting%22%0A%20%20%0A%20%20Set%20sld%20%3D%20TargetPresentation.Slides.Add(%20_%0A%20%20%20%20TargetPresentation.Slides.Count%20%2B%201%2C%20ppLayoutTitleOnly)%0A%20%20If%20sld.Shapes.HasTitle%20%3D%20msoTrue%20Then%20sld.Shapes.Title.TextFrame.TextRange.Text%20%3D%20ChartTitle%0A%20%20sld.Select%0A%20%20cnt%20%3D%20sld.Shapes.Count%0A%20%20With%20PowerPointApplication%0A%20%20%20%20If%20.CommandBars.GetEnabledMso(CtrlID1)%20%3D%20True%20Then%0A%20%20%20%20%20%20.CommandBars.ExecuteMso%20CtrlID1%0A%20%20%20%20Else%0A%20%20%20%20%20%20.CommandBars.ExecuteMso%20CtrlID2%0A%20%20%20%20End%20If%0A%20%20End%20With%0A%20%20Do%0A%20%20%20DoEvents%0A%20%20Loop%20Until%20cnt%20%26lt%3B%26gt%3B%20sld.Shapes.Count%0AEnd%20Sub%3C%2FCODE%3E%3C%2FPRE%3E%3C%2FLINGO-BODY%3E%3CLINGO-SUB%20id%3D%22lingo-sub-817898%22%20slang%3D%22en-US%22%3ERe%3A%20Excel%20charts%20to%20Powerpoint%20exporting%20using%20VBA%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-817898%22%20slang%3D%22en-US%22%3EWorks%20wonderfully.%20I%20really%20appreciate%20the%20help%20on%20this.%20Thank%20you!%3C%2FLINGO-BODY%3E%3CLINGO-SUB%20id%3D%22lingo-sub-854759%22%20slang%3D%22en-US%22%3ERe%3A%20Excel%20charts%20to%20Powerpoint%20exporting%20using%20VBA%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-854759%22%20slang%3D%22en-US%22%3E%3CP%3E%3CA%20href%3D%22https%3A%2F%2Ftechcommunity.microsoft.com%2Ft5%2Fuser%2Fviewprofilepage%2Fuser-id%2F247409%22%20target%3D%22_blank%22%3E%40kinuasa%3C%2FA%3E%26nbsp%3BThank%20you%2C%20the%20code%20works%20very%20well.%20I%20would%20like%20to%20be%20able%20to%20paste%20the%20charts%20as%20images%20as%20well%20as%20having%20the%20chart%20titles%20as%20the%20slide%20titles.%20I%20could%20not%20work%20out%20how%20to%20amend%20the%26nbsp%3B%3CSPAN%3EChartsToPptAsImage%20macro%20to%20include%20the%20titles%20as%20well.%20Would%20you%20be%20able%20to%20assist%3F%3C%2FSPAN%3E%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3E%3CSPAN%3ERegards%3C%2FSPAN%3E%3C%2FP%3E%3C%2FLINGO-BODY%3E
Aditya Jadhav
Contributor

Hi,

 

Can anyone share a code which can be used to copy and paste all the charts from a workbook to a powerpoint presenatation. Have about 95 different charts on different sheets in the workbook. Have searched for a macro but none has worked for me.

If anyone can share a code that can export all the charts it would really help me save my work.

 

Regards,

Aditya 

8 Replies
Solution

Hi,
please try the sample code below:

 

Public Sub ChartsToPpt()
  Dim sht As Object
  Dim cht As Excel.ChartObject
  Dim appPpt As Object 'PowerPoint.Application
  Dim prs As Object 'PowerPoint.Presentation
 
  'Create New Presentation
  Set appPpt = CreateObject("PowerPoint.Application")
  appPpt.Visible = msoTrue
  Set prs = appPpt.Presentations.Add(msoTrue)
 
  For Each sht In ActiveWorkbook.Sheets
    If sht.Visible = xlSheetVisible Then
      sht.Select
      Select Case LCase(TypeName(sht))
        Case "worksheet"
          For Each cht In sht.ChartObjects
            cht.Select
            Application.CommandBars.ExecuteMso "Copy"
            PasteChart appPpt, prs
          Next
        Case "chart"
          Application.CommandBars.ExecuteMso "Copy"
          PasteChart appPpt, prs
      End Select
    End If
  Next
End Sub

Private Sub PasteChart(ByVal PowerPointApplication As Object, _
                       ByVal TargetPresentation As Object)
  Dim sld As Object 'PowerPoint.Slide
  Dim cnt As Long
  Const ppLayoutBlank = 12
 
  Set sld = TargetPresentation.Slides.Add( _
    TargetPresentation.Slides.Count + 1, ppLayoutBlank) 'Add New Slide
  sld.Select
  cnt = sld.Shapes.Count
 
  PowerPointApplication.CommandBars.ExecuteMso "PasteExcelChartSourceFormatting"
  Do
   DoEvents
  Loop Until cnt <> sld.Shapes.Count
End Sub

 

-------------

 

Public Sub ChartsToPptAsImage()
  Dim sht As Object
  Dim cht As Excel.ChartObject
  Dim appPpt As Object 'PowerPoint.Application
  Dim prs As Object 'PowerPoint.Presentation
 
  'Create New Presentation
  Set appPpt = CreateObject("PowerPoint.Application")
  appPpt.Visible = msoTrue
  Set prs = appPpt.Presentations.Add(msoTrue)
 
  For Each sht In ActiveWorkbook.Sheets
    If sht.Visible = xlSheetVisible Then
      Select Case LCase(TypeName(sht))
        Case "worksheet"
          For Each cht In sht.ChartObjects
            cht.CopyPicture Appearance:=xlScreen, _
                            Format:=xlBitmap
            PasteChartImage prs
          Next
        Case "chart"
          sht.ChartArea.Copy
          PasteChartImage prs
      End Select
    End If
  Next
End Sub

Private Sub PasteChartImage(ByVal TargetPresentation As Object)
  Dim sld As Object 'PowerPoint.Slide
  Const ppLayoutBlank = 12
  Const ppPasteBitmap = 1
 
  Set sld = TargetPresentation.Slides.Add( _
    TargetPresentation.Slides.Count + 1, ppLayoutBlank) 'Add New Slide
  With sld.Shapes.PasteSpecial(DataType:=ppPasteBitmap, Link:=msoFalse)
    .Align msoAlignCenters, True
    .Align msoAlignMiddles, True
  End With
End Sub

 

hope this helps.
kinuasa

Hi Kinuasa,

This code worked very well and it did wonders for me.

Thank you so much for providing me with the solution.

 

Regards,

Aditya

@kinuasa  This is really helpful! Is there a way to get it to open a specific document instead of a new presentation?Also, is there a way to make it paste special (Use Destination Theme & Link Data) for the charts (they are made the way I want them in excel and lose that when pasted into the ppt, currently)?

@jstolme please try below code:

Option Explicit

Public Sub ChartsToPpt()
  Dim sht As Object
  Dim cht As Excel.ChartObject
  Dim appPpt As Object 'PowerPoint.Application
  Dim prs As Object 'PowerPoint.Presentation
  
  Set appPpt = CreateObject("PowerPoint.Application")
  appPpt.Visible = msoTrue
  Set prs = appPpt.Presentations.Open("C:\Test\Sample.pptx")
  
  For Each sht In ActiveWorkbook.Sheets
    If sht.Visible = xlSheetVisible Then
      sht.Select
      Select Case LCase(TypeName(sht))
        Case "worksheet"
          For Each cht In sht.ChartObjects
            cht.Select
            Application.CommandBars.ExecuteMso "Copy"
            PasteChart appPpt, prs
          Next
        Case "chart"
          Application.CommandBars.ExecuteMso "Copy"
          PasteChart appPpt, prs
      End Select
    End If
  Next
End Sub

Private Sub PasteChart(ByVal PowerPointApplication As Object, _
                       ByVal TargetPresentation As Object)
  Dim sld As Object 'PowerPoint.Slide
  Dim cnt As Long
  Const ppLayoutBlank = 12
  Const CtrlID1 = "PasteLinkedExcelChartDestinationTheme"
  Const CtrlID2 = "PasteExcelChartSourceFormatting"
  
  Set sld = TargetPresentation.Slides.Add( _
    TargetPresentation.Slides.Count + 1, ppLayoutBlank)
  sld.Select
  cnt = sld.Shapes.Count
  With PowerPointApplication
    If .CommandBars.GetEnabledMso(CtrlID1) = True Then
      .CommandBars.ExecuteMso CtrlID1
    Else
      .CommandBars.ExecuteMso CtrlID2
    End If
  End With
  Do
   DoEvents
  Loop Until cnt <> sld.Shapes.Count
End Sub

 

@kinuasaThank you! This worked great. I made a small edit to make the new slides contain a title (Const ppLayoutTitleOnly = 11).  The only thing I'm still trying to do is make the slide titles match the chart titles. I thought something like this may work, but I'm not sure where it would properly go or if it's appropriate given your approach. Thoughts?

'Copy and paste chart title as the slide title in PowerPoint
        currentSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text

 My current code is:

 

Public Sub ChartsToPpt()
  Dim sht As Object
  Dim cht As Excel.ChartObject
  Dim appPpt As Object 'PowerPoint.Application
  Dim prs As Object 'PowerPoint.Presentation
  
  Set appPpt = CreateObject("PowerPoint.Application")
  appPpt.Visible = msoTrue
  Set prs = appPpt.Presentations.Open("C:SAMPLE\PATH")
  
  For Each sht In ActiveWorkbook.Sheets
    If sht.Visible = xlSheetVisible Then
      sht.Select
      Select Case LCase(TypeName(sht))
        Case "worksheet"
          For Each cht In sht.ChartObjects
            cht.Select
            Application.CommandBars.ExecuteMso "Copy"
            PasteChart appPpt, prs
          Next
        Case "chart"
          Application.CommandBars.ExecuteMso "Copy"
          PasteChart appPpt, prs
      End Select
    End If
  Next
End Sub

Private Sub PasteChart(ByVal PowerPointApplication As Object, _
                       ByVal TargetPresentation As Object)
  Dim sld As Object 'PowerPoint.Slide
  Dim cnt As Long
  Const ppLayoutTitleOnly = 11
  Const CtrlID1 = "PasteLinkedExcelChartDestinationTheme"
  Const CtrlID2 = "PasteExcelChartSourceFormatting"
  
  Set sld = TargetPresentation.Slides.Add( _
    TargetPresentation.Slides.Count + 1, ppLayoutTitleOnly)
  sld.Select
  cnt = sld.Shapes.Count
  With PowerPointApplication
    If .CommandBars.GetEnabledMso(CtrlID1) = True Then
      .CommandBars.ExecuteMso CtrlID1
    Else
      .CommandBars.ExecuteMso CtrlID2
    End If
  End With
  Do
   DoEvents
  Loop Until cnt <> sld.Shapes.Count
End Sub

 

 

@jstolme Hi, please try below code:

Option Explicit

Public Sub ChartsToPpt()
  Dim sht As Object
  Dim cht As Excel.ChartObject
  Dim appPpt As Object 'PowerPoint.Application
  Dim prs As Object 'PowerPoint.Presentation
  Dim chtTitle As String
  
  Set appPpt = CreateObject("PowerPoint.Application")
  appPpt.Visible = msoTrue
  Set prs = appPpt.Presentations.Open("C:\Test\Sample.pptx")
  
  For Each sht In ActiveWorkbook.Sheets
    If sht.Visible = xlSheetVisible Then
      sht.Select
      Select Case LCase(TypeName(sht))
        Case "worksheet"
          For Each cht In sht.ChartObjects
            If cht.Chart.HasTitle = True Then chtTitle = cht.Chart.ChartTitle.Text
            cht.Select
            Application.CommandBars.ExecuteMso "Copy"
            PasteChart appPpt, prs, chtTitle
          Next
        Case "chart"
          If sht.HasTitle = True Then chtTitle = sht.ChartTitle.Text
          Application.CommandBars.ExecuteMso "Copy"
          PasteChart appPpt, prs, chtTitle
      End Select
    End If
  Next
End Sub

Private Sub PasteChart(ByVal PowerPointApplication As Object, _
                       ByVal TargetPresentation As Object, _
                       ByVal ChartTitle As String)
  Dim sld As Object 'PowerPoint.Slide
  Dim cnt As Long
  Const ppLayoutTitleOnly = 11
  Const CtrlID1 = "PasteLinkedExcelChartDestinationTheme"
  Const CtrlID2 = "PasteExcelChartSourceFormatting"
  
  Set sld = TargetPresentation.Slides.Add( _
    TargetPresentation.Slides.Count + 1, ppLayoutTitleOnly)
  If sld.Shapes.HasTitle = msoTrue Then sld.Shapes.Title.TextFrame.TextRange.Text = ChartTitle
  sld.Select
  cnt = sld.Shapes.Count
  With PowerPointApplication
    If .CommandBars.GetEnabledMso(CtrlID1) = True Then
      .CommandBars.ExecuteMso CtrlID1
    Else
      .CommandBars.ExecuteMso CtrlID2
    End If
  End With
  Do
   DoEvents
  Loop Until cnt <> sld.Shapes.Count
End Sub
Works wonderfully. I really appreciate the help on this. Thank you!

@kinuasa Thank you, the code works very well. I would like to be able to paste the charts as images as well as having the chart titles as the slide titles. I could not work out how to amend the ChartsToPptAsImage macro to include the titles as well. Would you be able to assist?

 

Regards

Related Conversations
How to Prevent Teams from Auto-Launch
chenrylee in Microsoft Teams on
28 Replies
Early preview of Microsoft Edge group policies
Sean Lyndersay in Discussions on
65 Replies
*Updated 9/3* Syncing in Microsoft Edge Preview Channels
Elliot Kirk in Articles on
201 Replies
Tabs and Dark Mode
cjc2112 in Discussions on
2 Replies