Hi,
I'm trying to figure out how to get the code below to loop correctly so would appreciate any help.
Essentially the loop needs to look in each worksheet and if there's a '1' in cell S1 to then copy & paste the range 'Print_Area' into a blank PowerPoint slide with a slide for each instance.
The code below adds in the right number of sheets but only pastes the first worksheet into all the slides which I want to change so that each instance has its own slide.
Thanks in advance for any help.
I'm trying to figure out how to get the code below to loop correctly so would appreciate any help.
Essentially the loop needs to look in each worksheet and if there's a '1' in cell S1 to then copy & paste the range 'Print_Area' into a blank PowerPoint slide with a slide for each instance.
The code below adds in the right number of sheets but only pastes the first worksheet into all the slides which I want to change so that each instance has its own slide.
Thanks in advance for any help.
Code:
Sub ExcelRangeToPowerPoint()
'PURPOSE: Copy/Paste An Excel Range Into a New PowerPoint Presentation
Dim rng As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim ws As Worksheet
'Copy Range from Excel
Set rng = ThisWorkbook.ActiveSheet.Range("Print_Area")
'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
'Optimize Code
Application.ScreenUpdating = False
'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add
'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
For Each ws In ActiveWorkbook.Worksheets
If ws.Range("S1") = "1" Then
'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, ppLayoutBlank) '11 = ppLayoutTitleOnly
'Copy Excel Range
rng.Copy
'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=10 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
'Set position:
myShape.Left = 15
myShape.Top = 15
myShape.Width = 690
End If
Next ws
'Make PowerPoint Visible and Active
PowerPointApp.Visible = True
PowerPointApp.Activate
'Clear The Clipboard
Application.CutCopyMode = False
End Sub