excel charts to powerpoint vba

Question

I have a standard code that prints all charts in your active sheet to a new powerpoint application:

Sub CreatePowerPoint()

'First we declare the variables we will be using
    Dim newPowerPoint As PowerPoint.Application
    Dim activeSlide As PowerPoint.Slide
    Dim cht As Excel.ChartObject

 'Look for existing instance
    On Error Resume Next
    Set newPowerPoint = GetObject(, "PowerPoint.Application")
    On Error GoTo 0

'Let's create a new PowerPoint
    If newPowerPoint Is Nothing Then
        Set newPowerPoint = New PowerPoint.Application
    End If
'Make a presentation in PowerPoint
    If newPowerPoint.Presentations.Count = 0 Then
        newPowerPoint.Presentations.Add
    End If

'Show the PowerPoint
    newPowerPoint.Visible = True

'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
    For Each cht In ActiveSheet.ChartObjects

    'Add a new slide where we will paste the chart
        newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText
        newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
        Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)

    'Copy the chart and paste it into the PowerPoint as a Metafile Picture
        cht.Select
        ActiveChart.ChartArea.Copy
        activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select

    'Set the title of the slide the same as the title of the chart
        activeSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text

    'Adjust the positioning of the Chart on Powerpoint Slide
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 15
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 125

        activeSlide.Shapes(2).Width = 200
        activeSlide.Shapes(2).Left = 505

    Next

AppActivate ("Microsoft PowerPoint")
Set activeSlide = Nothing
Set newPowerPoint = Nothing

End Sub

What I need to do is change the instead of activesheet to whole workbook, so copy over all charts in workbook. I tried introducing what I use to read through the workbook and delete all sheets :

Sub ClearCharts()

Dim wsItem As Worksheet
Dim chtObj As ChartObject

For Each wsItem In ThisWorkbook.Worksheets

    For Each chtObj In wsItem.ChartObjects

        chtObj.Delete

    Next

Next

End Sub

but it runs and doesnt copy over the charts when I try and edit the activesheet line. Any ideas would be appreciated for me to progress.

Thankyou

Answer 1

I'm trying to do a similar thing at the moment, looking at the code above you have 3 For Each loops but you should only have 2 I believe. One to Loop over the sheets and a second to loop over each chart in the sheet.

Answer 2

You have to activate the sheet before you export the chart. I have faced this problem in the past when exporting the charts.

Try this

Dim wsItem As Worksheet
Dim chtObj As ChartObject

For Each wsItem In ThisWorkbook.Worksheets
    For Each chtObj In wsItem.ChartObjects

        wsItem.Activate

        '~~> Code here to copy it to the poerpoint
        '~~> Same for deleting it

        DoEvents

    Next
Next

Answer 3

` Sub SelectedSheetsPowerPoint()

Dim wsItem As Worksheet
Dim chtObj As ChartObject
For Each wsItem In ThisWorkbook.Worksheets
For Each chtObj In wsItem.ChartObjects
wsItem.Activate
'~~> Code here to copy it to the poerpoint
'~~> Same for deleting it


'First we declare the variables we will be using
    Dim newPowerPoint As PowerPoint.Application
    Dim activeSlide As PowerPoint.Slide
    Dim cht As Excel.ChartObject

 'Look for existing instance
    On Error Resume Next
    Set newPowerPoint = GetObject(, "PowerPoint.Application")
    On Error GoTo 0

'Let's create a new PowerPoint
    If newPowerPoint Is Nothing Then
        Set newPowerPoint = New PowerPoint.Application
    End If
'Make a presentation in PowerPoint
    If newPowerPoint.Presentations.count = 0 Then
        newPowerPoint.Presentations.Add
    End If

'Show the PowerPoint
    newPowerPoint.Visible = True

'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
    For Each cht In ActiveSheet.ChartObjects

    'Add a new slide where we will paste the chart
        newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.count + 1, ppLayoutText
        newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.count
        Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.count)

    'Copy the chart and paste it into the PowerPoint as a Metafile Picture
        cht.Select
        ActiveChart.ChartArea.Copy
        activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select

    'Set the title of the slide the same as the title of the chart
        activeSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text

    'Adjust the positioning of the Chart on Powerpoint Slide
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 75
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 120

        activeSlide.Shapes(2).Width = 200
        activeSlide.Shapes(2).Left = 505
     'loop through each chart in !!activesheet!! and move each into a new slide!
    Next
'start pp, can add preset headings for power point here
AppActivate ("Microsoft PowerPoint")
Set activeSlide = Nothing
Set newPowerPoint = Nothing

DoEvents

Next
Next

End Sub

`

it runs through and puts out all graphs but it doesn't stop, it will just keep copying and looping through all the sheets until I closed it out after it copied about 15 times.