Generate_PowerPoint

Creates PowerPoint slideshow file from Excel range(s) with slide per sheet (or just 1 slide for 1 sheet) and saves pps next to workbook.
User may pass range, and sheet or sheets names that want to create slides from and the PPS filename to save into.
PPS file extension turns out to be the best one for filesize aspect. /?DevID=E3RITXA3

CodeFunctionName

What is this?

Public

Tested

Original Work

Function Generate_PowerPoint(Optional SlideRange = "A1:M12", Optional SheetsList = "Sheet1|Sheet2", Optional WBName = "This", Optional PPSFileName = "")
    ' Copy and paste defined range from all sheets in SheetsList into slideshow as picture (1 slide per sheet) and saves PowerPoint as slideshow next to Excel file
    '    Will resize picture to fill the slide
    '
    ' Originally from https://chandoo.org/wp/create-powerpoint-presentations-using-excel-vba/
    '
    ' Add a reference to the Microsoft PowerPoint Library by:
    ' 1. Go to Tools in the VBA menu
    ' 2. Click on Reference
    ' 3. Scroll down to Microsoft PowerPoint X.0 Object Library, check the box, and press Okay

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

    If WbName = "" Then WbName = ThisWorkbook.name
    If WbName = "This" Then WbName = ThisWorkbook.name
    If SlideRange = "" Then SlideRange = "A1:M12"
    If SheetsList = "" Then SheetsList = "Sheet1"

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

    Application.ScreenUpdating = True

    PicPasteAs = 1 ' paste as png or bmp (See )

    If newPowerPoint Is Nothing Then 'Let's create a new PowerPoint
        Set newPowerPoint = New PowerPoint.Application
    End If
    newPowerPoint.Presentations.Add 'Make a new presentation in PowerPoint
    newPowerPoint.Visible = True ' Show the PowerPoint

    ' Loop through our sheets and paste them as images
    ' Create new slide for every sheet we have in Excel
    For Each Shee in Split(SheetsList, "|")
        If FindSheet(CStr(Shee)) Then
            DoEvents
            newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutBlank
            newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
            Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)

            Workbooks(WbName).Activate
            Workbooks(WbName).Worksheets(Shee).Activate
            DoEvents
            Workbooks(WbName).Worksheets(Shee).Range("A1").Copy ' To force clipboard clear

            Workbooks(WbName).Worksheets(Shee).Range(SlideRange).Copy

            activeSlide.Shapes.PasteSpecial PicPasteAs
            DoEvents
            activeSlide.Shapes(activeSlide.Shapes.Count).Select
            DoEvents

            newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 0
            DoEvents
            newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 0
            DoEvents
            newPowerPoint.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse
            DoEvents
            newPowerPoint.ActiveWindow.Selection.ShapeRange.Width = activeSlide.CustomLayout.Width
            DoEvents
            newPowerPoint.ActiveWindow.Selection.ShapeRange.Height = activeSlide.CustomLayout.Height
            DoEvents
        End If
    Next
    PPT2 = FixPath() & PPSFileName
    DoEvents
    newPowerPoint.ActivePresentation.SaveAs PPT2, ppSaveAsShow
    AppActivate "PowerPoint"
    GoTo ByeBye
ByeBye:
    Set activeSlide = Nothing
    Set newPowerPoint = Nothing
End Function

Optional SlideRange = "A1:M12", Optional SheetsList = "Sheet1|Sheet2", Optional WBName = "This", Optional PPSFileName = ""