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
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 = ""
Views 680
Downloads 280
CodeID
DB ID
ANmarAmdeen
601
Revisions
v1.0
Tuesday
December
22
2020