How to Change VBA Code to Copy Charts to Already Open PowerPoint? Please Help

[asalman07]

I have this code below that opens up a PowerPoint but what Changes can I make to it so that my Excel Charts will copy to an Existing Powerpiont that I already have open? The reason is because we already have Templates in Powerpoint that I need to keep using. I would like to Open this PPT Template before I link my Charts. Thanks

Thanks in advance for any help!

Option Explicit
Sub CopyChartsToPowerPoint()
'
'Excel Application objects declaration
Dim ws As Worksheet
Dim objChartObject As ChartObject
Dim objChart As Chart
Dim objCht As Chart
Dim lngSlideKount As Long
'
'Powerpoint Application objects declaration
' You need to add a reference (Tools | References) to the Microsoft PowerPoint nn.nn Object Library
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSld As PowerPoint.Slide
'
On Error GoTo Error_Para
'
'Create a new Powerpoint session
Set pptApp = CreateObject("PowerPoint.Application")
'
pptApp.Visible = msoTrue
'Create a new presentation
Set pptPres = pptApp.Presentations.Add
Set pptPres = pptApp.ActivePresentation
'
pptApp.ActiveWindow.ViewType = ppViewSlide
'
lngSlideKount = 0
For Each ws In ActiveWorkbook.Worksheets
'Verify if there is a chart object to transfer
If ws.ChartObjects.Count > 0 Then
For Each objChartObject In ws.ChartObjects
Set objChart = objChartObject.Chart
'ppLayoutBlank = 12
Set pptSld = pptPres.Slides.Add(lngSlideKount + 1, 12)
pptApp.ActiveWindow.View.GotoSlide pptSld.SlideIndex
With objChart
'Copy chart object as pict
objChart.ChartArea.Copy
'Paste copied chart into new slide
pptSld.Shapes.PasteSpecial(Link:=msoCTrue).Select
pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
End With
lngSlideKount = lngSlideKount + 1
Next objChartObject
End If
Next ws
' Now check CHART sheets:
For Each objCht In ActiveWorkbook.Charts
'ppLayoutBlank = 12
Set pptSld = pptPres.Slides.Add(lngSlideKount + 1, 12)
pptApp.ActiveWindow.View.GotoSlide pptSld.SlideIndex
With objCht
'Copy chart object as
.ChartArea.Copy '
'Paste copied chart picture into new slide
pptSld.Shapes.PasteSpecial(Link:=msoCTrue).Select '
pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
End With
lngSlideKount = lngSlideKount + 1
Next objCht
'
'Activate PowerPoint application
pptApp.ActiveWindow.ViewType = ppViewNormal
pptApp.Visible = True
pptApp.Activate
If lngSlideKount > 0 Then
If lngSlideKount = 1 Then
MsgBox "1 chart was copied to PowerPoint", vbOKOnly + vbInformation, "Information"
Else
MsgBox lngSlideKount & " charts were copied to PowerPoint", vbOKOnly + vbInformation, "Information"
End If
End If
GoTo Exit_Para
Error_Para:
MsgBox "Error " & Err.Number & vbCrLf & vbCrLf & _
Err.Description & vbCrLf & vbCrLf & _
"copying charts to PowerPoint", vbOKOnly + vbCritical, "Error"
Exit_Para:
On Error Resume Next
Set ws = Nothing
Set objChart = Nothing
Set objChartObject = Nothing
Set pptSld = Nothing
Set pptPres = Nothing
Set pptApp = Nothing
End Sub

 

[Jon Peltier]

You had the answer:

Set pptPres = pptApp.Presentations.Add
Set pptPres = pptApp.ActivePresentation

Just use the second line:

Set pptPres = pptApp.ActivePresentation

 

[asalman07]

Thank you Jon, I didn't realize I had that in there. Thanks!

You had the answer:

Set pptPres = pptApp.Presentations.Add
Set pptPres = pptApp.ActivePresentation

Just use the second line:

Set pptPres = pptApp.ActivePresentation