Create Multiple PPT Files from Multiple Excel file using VBA

[mlourica]

Hello!
I am looking for a way to mass produce Multiple PPTs from Multiple Variable Designated Excel files.


I have been able to create 1 PPT from 1 designated Excel file using VBA below
The code used before is very static and I'm looking for a way to make it more automated. This Static code is how I used VBA to open a PPT Template, Copy/Paste worksheets from SAS Output in Excel, Copy/Paste Cell ranges to PPT slides, then save/close the new PPT.

Sub RunReports()



' setting variables
Dim j As Integer
Dim FirstReport As Integer
Dim LastReport As Integer

' handling error popups
On Error Resume Next

' looping through the QPR creation process
For j = FirstReport To LastReport
Range("Counter") = j
Calculate
Call CreatePPT
Next j

End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub CreatePPT()

' Declare Variables

Dim PPapp As PowerPoint.Application
Dim PPfile As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim MyShape As PowerPoint.ShapeRange
Dim wbk As Workbook
Dim Rng(1 To 60) As Excel.Range
Dim MyPPFile, PPPathFile, PPReportPath, MyWorkbook, MyFileName, SlideName(1 To 60), SlideRange(1 To 60) As String
Dim i, SlideNum, FirstSlide, LastSlide, NumSlides, SlideTop(1 To 60), SlideLeft(1 To 60) As Integer
Dim SlideSize(1 To 60) As Double

' Turn off error popups
On Error Resume Next

' Getting # of slides
FirstSlide = Range("FirstSlide").Value
NumSlides = Range("SlideNo").Value
LastSlide = Range("LastSlide").Value

' Getting sheet names and slide measures
For i = 1 To NumSlides
SlideName(i + FirstSlide - 1) = Cells(12 + i, 5)
SlideRange(i + FirstSlide - 1) = Cells(12 + i, 6)
SlideLeft(i + FirstSlide - 1) = Cells(12 + i, 7)
SlideTop(i + FirstSlide - 1) = Cells(12 + i, 8)
SlideSize(i + FirstSlide - 1) = Cells(12 + i, 9)
Next i



' getting the location of the blank QPR powerpoint
PPReportPath = Range("PPTpath") & "\" & Range("PPTfilename")

'setting the powerpoint application as an object to be handled by VBA
Set PPapp = CreateObject("PowerPoint.Application")
' handling powerpoint if it's already opened
' If PPapp Is Nothing Then Set PPapp = New PowerPoint.Application
' opening Powerpoint
Set PPfile = PPapp.Presentations.Open(PPReportPath)
PPapp.Visible = True
PPapp.Activate

' setting the loop to copy/paste the sheets from excel to powerpoint
For i = FirstSlide To LastSlide
Set Rng(i) = Sheets(SlideName(i)).Range(SlideRange(i))
Rng(i).CopyPicture Format:=xlPicture
Set mySlide = PPfile.Slides(i)

Set MyShape = mySlide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)
With MyShape
.IncrementLeft SlideLeft(i)
.IncrementTop SlideTop(i)
.Height = SlideSize(i) * .Height
End With
Next i

' Geting name for powerpoint
MyFileName = Range("FileName")
' Setting the name and location of the new QPR
MyPPFile = Range("PPTpath") & "\" & MyFileName & ".pptx"
' Saving the QPR
PPfile.SaveAs (MyPPFile)
' Closing the file
PPfile.Close
' Here we can exit out of powerpoint, but if we're running more than one report it's faster to leave it open

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub CopySheetFromClosedWB()
Application.ScreenUpdating = False

Set closedBook = Workbooks.Open(Range("CLTPath").Value & "\" & Range("CLTFile").Value)
closedBook.Sheets("Leavers & Stayers - Level 3 SP").Copy Before:=ThisWorkbook.Sheets(1)
closedBook.Sheets("Leavers & Stayers - Level 3 Tr").Copy Before:=ThisWorkbook.Sheets(1)
closedBook.Sheets("Leavers & Stayers - Level 3").Copy Before:=ThisWorkbook.Sheets(1)
closedBook.Sheets("Utilization and Cost SummaryS").Copy Before:=ThisWorkbook.Sheets(1)
closedBook.Sheets("Utilization and Cost SummaryT").Copy Before:=ThisWorkbook.Sheets(1)
closedBook.Sheets("Utilization and Cost SummaryA").Copy Before:=ThisWorkbook.Sheets(1)
closedBook.Sheets("UC Summary").Copy Before:=ThisWorkbook.Sheets(1)
closedBook.Sheets("P&I Specialty").Copy Before:=ThisWorkbook.Sheets(1)
closedBook.Sheets("P&I Traditional").Copy Before:=ThisWorkbook.Sheets(1)
closedBook.Sheets("P&I").Copy Before:=ThisWorkbook.Sheets(1)
closedBook.Sheets("Title").Copy Before:=ThisWorkbook.Sheets(1)

closedBook.Close SaveChanges:=False

Application.ScreenUpdating = True
End Sub

 

[mlourica]

Overall I am looking to create a loop of this old code to mass produce these PPT's in one step. I'm struggling with combining the two loops. 1 new MassPPT() reading down a column of file names for a specific amount of 'i' , creating individual PPTs for 10 output excel files. My first attempt.

Sub MassPPT()


' setting variables
Dim i As Integer
Dim FirstReport1 As Integer
Dim LastReport1 As Integer

' handling error popups
On Error Resume Next

' looping through the Mass creation process
For i = FirstReport1 To LastReport1
Range("Counter1") = i
Calculate
Call CreateMassPPT
Call CreatePPT
Next i

End Sub