Categorised Menu List

Creating a Powerpoint Presentation from Excel

How it works: 

based on the code, the spread sheet is formatted into different styles.

 

to experiment:

  1. Put some data in excel file
  2. Graph is generated automatically
  3. copy and paste the following code
  4. assign this to a button on screen
  5. click the button to execute the code.

Context: 

To Create a Power point Presentation from Excel. There will be numerous problems involved with this idea., starting with target system screen resolution, version, source version, also depends on patch updates.,

So, this or any of this type of solution can not be perfect (limited to my experience) but useful to impress upon your boss, to tell him that you are working on something innovative. 

    EXCEL TO POWERPOINT

    COPIES DATA AND GRAPHS TO POWERPOINT

    Sub CreatePresentation()
    Dim ppt As PowerPoint.Application
    Dim pres As PowerPoint.Presentation
    Dim sSaveAs As String
    Dim ws As Worksheet
    Dim chrt As Chart
    Dim nSlide As Integer
        
        'On Error GoTo ErrHandler
        Set ws = ThisWorkbook.Worksheets("Reports")
        ' Create a new instance of PowerPoint
        Set ppt = New PowerPoint.Application
        ' Create a new presentation
        Set pres = ppt.Presentations.Add

     

    'Update this path as per your template stored template ends with extension .potx

    pres.ApplyTemplate "D:\Genpact\Templates\Genpact_Template.potx"
        With pres.Slides.Add(1, ppLayoutTitle)
            .Shapes(1).TextFrame.TextRange.Text = "Quaterly Sales Analysis"
            .Shapes(2).TextFrame.TextRange.Text = "10/6/2013"
        End With

     

    ' Copy data
    'CopyDataRange pres, ws.Range("Sales_Summary"), 2, 2
    CopyChart pres, ws.ChartObjects(1).Chart, 3, 1

     

    ' Save & close the presentation file
    sSaveAs = GetSaveAsName("Save As")
        If sSaveAs <> "False" Then pres.SaveAs sSaveAs

    pres.Close
    ExitPoint:

     

    Application.CutCopyMode = False
        Set chrt = Nothing
        Set ws = Nothing
        Set pres = Nothing
        Set ppt = Nothing
    Exit Sub
        Resume ExitPoint
    End Sub

     

     

    Sub CopyDataRange(pres As PowerPoint.Presentation, rg As Range, nSlide As Integer, dScaleFactor As Double)
        ' copy range to clipboard
        rg.Copy
        ' add new blank slide
        pres.Slides.Add nSlide, ppLayoutBlank
        ' paste the range to the slide
        pres.Slides(nSlide).Shapes.PasteSpecial ppPasteOLEObject
        ' scale the pasted object in PowerPoint
        pres.Slides(nSlide).Shapes(1).ScaleHeight dScaleFactor, msoTrue
        pres.Slides(nSlide).Shapes(1).ScaleWidth dScaleFactor, msoTrue
        
        ' Center Horizontally & Vertically
        ' Might be a good idea to move this outside this procedure
        ' so you have more control over whether this happens or not
        CenterVertically pres.Slides(nSlide), pres.Slides(nSlide).Shapes(1)
        CenterHorizontally pres.Slides(nSlide), pres.Slides(nSlide).Shapes(1)
    End Sub

     

     

    Sub CopyChart(pres As PowerPoint.Presentation, chrt As Chart, nSlide As Integer, dScaleFactor As Double)
        ' copy chart to clipboard as a picture
        chrt.CopyPicture xlScreen
        ' add slide
        pres.Slides.Add nSlide, ppLayoutBlank
        ' copy chart to PowerPoint
        pres.Slides(nSlide).Shapes.PasteSpecial ppPasteDefault
        ' scale picture
        pres.Slides(nSlide).Shapes(1).ScaleHeight dScaleFactor, msoTrue
        pres.Slides(nSlide).Shapes(1).ScaleWidth dScaleFactor, msoTrue
        ' Center Horizontally & Vertically
        ' Might be a good idea to move this outside this procedure
        ' so you have more control over whether this happens or not
        CenterVertically pres.Slides(nSlide), pres.Slides(nSlide).Shapes(1)
        CenterHorizontally pres.Slides(nSlide), pres.Slides(nSlide).Shapes(1)
    End Sub

     

     

    Sub CenterVertically(sl As PowerPoint.Slide, sh As PowerPoint.Shape)
    Dim lHeight As Long
        lHeight = sl.Parent.PageSetup.SlideHeight
        sh.Top = (lHeight - sh.Height) / 2
    End Sub

     

     

    Sub CenterHorizontally(sl As PowerPoint.Slide, sh As PowerPoint.Shape)
    Dim lWidth As Long
        lWidth = sl.Parent.PageSetup.SlideWidth
        sh.Left = (lWidth - sh.Width) / 2
    End Sub

     

     

    Function GetSaveAsName(sTitle As String) As String
    Dim sFilter As String
    sFilter = "Presentation (*.pptx), *.pptx"
        GetSaveAsName = Application.GetSaveAsFilename(filefilter:=sFilter, Title:=sTitle)
    End Function
     

    Issues you may encounter: While you copy and paste the code from here to code window, replace double quotes in code window again, as these quotes will appear as smart quotes.

    Always take care to check, if required references are checked

     

    I am publishing with a pure intension to help, as the resources on Outlook are very scarce.,

    I had to try very hard to even to get very little help.,  All the code is functional at my end, and I respect every sort of disclaimer, explicitly, I dont take any responsibility what so ever.

    It is always advisable to make best use of status bar.  Application.StatusBar = "some text"

    This will help end user to know that the work is in progress...

    gallery/excel to ppt
    gallery/excel to ppt code window

    Code Copied from Code window and pasted here as:is