excel charts to powerpoint vba - excel

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.