VBA Embedded Excel Graphs to Powerpoint (with a twist)

Kattenhove

New Member
Joined
Sep 24, 2014
Messages
2
Hi there,

Hoping someone is able to help a struggling amateur - would be greatly appreciated.
So I have a workbook with a set of worksheets each containing graphs relevant for a specific project.

Firstly I would love to create a macro that loops through each worksheet, and for each sheet, it then paste all graph objects to a NEW powerpoint presentation. This would allow me to quickly assemble my work for presentations.

Another way to go about it would be to be able to have the user select from a list of the worksheet names (projects) and have it subsequently export all graphs from the relevant sheet to a new powerpoint presentation.

I have tried with amateur alterations of Jon Peltier's code (included below), but I'm hopeful someone have had the same need or can trivially help me ammend the code to my needs!

/Thanks!

Code:
[COLOR=#0000CC][FONT=courier new][B]Sub ChartsToPresentation()[/B][/FONT][/COLOR]' Set a VBE reference to Microsoft PowerPoint Object Library

Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim PresentationFileName As Variant
Dim SlideCount As Long
Dim iCht As Integer

' Reference existing instance of PowerPoint
Set PPApp = GetObject(, "Powerpoint.Application")
' Reference active presentation
Set PPPres = PPApp.ActivePresentation
PPApp.ActiveWindow.ViewType = ppViewSlide

For iCht = 1 To ActiveSheet.ChartObjects.Count
    ' copy chart as a picture
    ActiveSheet.ChartObjects(iCht).Chart.CopyPicture _
        Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture

    ' Add a new slide and paste in the chart
    SlideCount = PPPres.Slides.Count
    Set PPSlide = PPPres.Slides.Add(SlideCount + 1, ppLayoutBlank)
    PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
    With PPSlide
        ' paste and select the chart picture
        .Shapes.Paste.Select
        ' align the chart
        PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
        PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
    End With

Next

' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
 [COLOR=#0000CC][FONT=courier new][B]End Sub[/B][/FONT][/COLOR]
 

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,167,992
Messages
5,856,692
Members
431,828
Latest member
kARTIK12345

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top