VBA Embedded Excel Graphs to Powerpoint (with a twist)

[Kattenhove]

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!

[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]

 

[Kattenhove]

Bump in the hope that someone can help!