Save each PPT slide as separate file

Hi,

Good Morning Everyone. Here is what I'm trying to do. I have a monthly presentation that I prepare for a large number of locations. Each location gets it's own slide. The way my Excel file is currently setup is I have one worksheet and all of the data/metrics/graph info pulls by VLOOKUP from a seperate data tab. I am able to toggle through the different locations by using a drop down menu on that tab. The location name I select from that dropdown is where all of the VLOOKUPS pull from.

I am trying to automate this process for myself. I have the VBA language to copy the range of data and paste it as an image into a powerpoint slide. Where I'm stuck is the code creates one consolidated presentation for all the location (slides) as it scroll through the drop down list of locations (or just paste the value of the location from the list the drop down menu pullls from into the actual drop down cell/field) and create a slide for each location in one consolidate presentation for all the locations slides, how can i save each location slide as separate powerpoint file the name of each slide to be picked up from the excel list which is used to create the drop down list. I have the list of the loactions in column "G". The code should create one slide save it as "file" as per the name from excel list then move on to create the next slide and save it as "file" asper the excel list and so on....

Below is the code that is am using to create the powerpoint.

Please Login or Register  to view this content.

Sub ExcelRangeToPowerPoint()
'PURPOSE: Copy/Paste An Excel Range Into a New PowerPoint Presentation
'NOTE: Must have PowerPoint Object Library Active in Order to Run _
(VBE > Tools > References > Microsoft PowerPoint 14.0 Object Library)
Dim rng As Excel.Range, PowerPointApp As PowerPoint.Application
Dim myPresentation As PowerPoint.Presentation, mySlide As PowerPoint.Slide
Dim myShapeRange As PowerPoint.ShapeRange, i%, ash As Worksheet
Set ash = ActiveSheet
Set rng = ash.Range("A1:D18")
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
'Make PowerPoint Visible and Active
PowerPointApp.Visible = True
PowerPointApp.Activate
'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add
For i = 0 To 28
ash.Range("K1") = ash.Range("G1").Offset(i)
Set mySlide = myPresentation.Slides.Add(1, 12)
rng.Copy
Application.Wait Now + TimeValue("00:00:01")
Set myShapeRange = mySlide.Shapes.PasteSpecial(DataType:=2)
myShapeRange.Left = 0.5 * 72
myShapeRange.Top = 0.5 * 72
myShapeRange.Height = 8 * 72
myShapeRange.Width = 9.2 * 72
myShapeRange.LockAspectRatio = msoTrue
Next
Application.CutCopyMode = False
End Sub

Please Login or Register  to view this content.