Save & Close powerpoint through Excel VBA

Question

Below is code that creates multiple charts based on defined names, then opens powerpoint files with those defined names and dumps in the charts. I have everything working except the last part: save and close the file.

I've marked in green my attempts at trying to save and close the files. Any help is appreciated!

Sub Slide19()
Dim rngx As Range
Dim rngy As Range
Dim rngz As Range

Dim ws As Worksheet
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim icnt As Long
Dim lastrow As Long
Dim k As Long
Dim icounter As Long
Dim a As Long
Dim b As Long
Dim c As Long
Dim d As Variant
Dim Chart As ChartObject
Dim PPapp As Object
Dim PPTDoc As PowerPoint.Presentation
Dim PPT As PowerPoint.Application
Dim PPpres As Object
Dim pptSlide As PowerPoint.Slide
Dim ppslide As Object

Dim filename As String
Dim filename2 As String

Set ws = Worksheets("Reference")
Set ws1 = Worksheets("Levels")
Set ws2 = Worksheets("Slide 19")

ws2.Activate
ws2.Range("e:f").NumberFormat = "0%"
lastrow = ws2.Cells(Rows.Count, "b").End(xlUp).Row
For icounter = 1 To lastrow
For icnt = 14 To 20
If ws2.Cells(icounter, 2) = ws.Cells(icnt, 3) Then

'd = ws.Cells(icnt, 3)
a = icounter + 1
b = icounter + 2
c = icounter + 12
filename = "filepath" & ws2.Cells(icounter, 2) & ".pptx"
filename2 = "xxyyxx" & ws2.Cells(icounter, 2)

'create RBI Vs LTM
Set rngx = Range(Cells(a, 4), Cells(c, 4))
        Set rngy = Range(Cells(a, 5), Cells(c, 6))

            ws2.Shapes.AddChart.Select
          ' ActiveChart.Name = ws2.Cells(icounter, 2) & "Slide8"
            ActiveChart.ChartType = xlColumnClustered
            ActiveChart.SetSourceData Source:=Union(rngx, rngy), PlotBy:=xlColumns

            With ActiveChart
            '.Name = d & "Slide8"
            .SetElement (msoElementChartTitleAboveChart)
            .ChartGroups(1).Overlap = 0
            .Legend.Delete
            .ChartTitle.Select
            .ChartTitle.Text = "Engagement by Level"
            .SeriesCollection(1).ApplyDataLabels
            .SeriesCollection(2).ApplyDataLabels

            .SeriesCollection(1).Interior.Color = RGB(0, 101, 179)
            .SeriesCollection(2).Interior.Color = RGB(192, 80, 77)
            .Axes(xlValue).MaximumScale = 1
           ' .Axes(xlValue).MinimumScale = 0.5
            '.Height = 374.4
            '.Width = 712.8

            .Axes(xlValue).TickLabels.NumberFormat = "0%"
            .SetElement (msoElementLegendRight)
            End With

            ActiveChart.Axes(xlValue).MajorGridlines.Select
            Selection.Format.Line.Visible = msoFalse
            ActiveChart.Legend.Select
            Selection.Left = 466.71
            Selection.Top = 12.467


            Set rngx = Nothing
            Set rngy = Nothing


With ActiveChart.Parent
.Height = Application.InchesToPoints(5.2)
.Width = Application.InchesToPoints(9.9)
End With

Set PPapp = CreateObject("Powerpoint.Application")

Set PPT = New PowerPoint.Application
PPT.Presentations.Open filename:=filename

PPapp.ActiveWindow.View.GotoSlide Index:=9


ActiveChart.ChartArea.Copy
PPapp.ActiveWindow.Panes(1).Activate
PPapp.CommandBars.ExecuteMso "PasteExcelChartSourceFormatting"
'PPT.ActivePresentation.SaveAs filename
'PPT.Presentations(filename2).Close
'PPapp.Quit


'PPT.Presentations.Close
End If
'PPapp.Quit
Next icnt
Next icounter
'PPapp.Quit



End Sub

Show source
| excel-vba   | vba   | excel   | powerpoint-vba   2017-01-06 19:01 2 Answers

Answers to Save & Close powerpoint through Excel VBA ( 2 )

  1. 2017-01-06 19:01

    I just tested the below which opens an instance of Powerpoint, makes it visible, creates a presentation, saves the presentation (path will need to be changed), quits the app and discharges the variable. Please let me know if this does not suit your needs.

    Sub ppt()
    Dim ppt As New PowerPoint.Application
    Dim pres As PowerPoint.Presentation
    ppt.Visible = True
    Set pres = ppt.Presentations.Add
    pres.SaveAs "C:\Users\xxx\Desktop\ppttest.pptx"
    pres.Close
    ppt.Quit
    Set ppt = Nothing
    End Sub
    
  2. 2017-01-06 19:01

    Your code to save and close presentation should work properly. The only thing should be done is to put waiting function between saving and closing as closing line doesn't 'wait' for saving which is causing errors.

    PPT.ActivePresentation.SaveAs filename
    waiting(7) 'For my usage 7 seconds waiting is enough - it depends on size of your presentation
    PPT.Presentations(filename2).Close
    

    Function for waiting:

    Sub waiting(tsecs As Single)
    Dim sngsec As Single
    
    sngsec = Timer + tsecs
    Do While Timer < sngsec
        DoEvents
    Loop
    
    End Sub
    

    And afterwards you can use:

    PPT.Quit
    set PPT = Nothing
    

Leave a reply to - Save & Close powerpoint through Excel VBA

◀ Go back