Macro to open Powerpoint and paste ranges from Excel - Troubleshoot error in code

[onthegreen03]

Hi -

I have some code that I copied from other users on line which opens PP (Procedure1) and then copies and pastes ranges from Excel (Procedure2) into that PP. When I run the code below it opens the Powerpoint no problem but it breaks down in Procedure2. Can someone help me figure out what needs to be fixed in Procedure 2 so that it copies/pastes the selected range into the PP opened in Procedure1? The code breaks at the "Add a slide to the presentation" step. Hopefully this makes sense. Many thanks for your help!

---------------------------------------------------------------------

Sub RunAllMacros()
Procedure1
Procedure2
End Sub

Sub Procedure1()

Dim objPPT As Object

Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True

objPPT.Presentations.Open "C:\users\migreen\AppData\Roaming\Microsoft\Templates\Blank.potx"

End Sub

Sub Procedure2()

Dim rng As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object

'Copy Range from Excel
Set rng = ThisWorkbook.ActiveSheet.Range("A1:C12")

'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly

'Copy Excel Range
rng.Copy

'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)

'Set position:
myShape.Left = 66
myShape.Top = 152

'Make PowerPoint Visible and Active
PowerPointApp.Visible = True
PowerPointApp.Activate

'Clear The Clipboard
Application.CutCopyMode = False

End Sub

 

[Worf]

This version includes two new variables:

Tsl – number of layout containing title and subtitle placeholders

Bl – number of layout that has the desired background for data slides

Dim objppt As PowerPoint.Application
Sub RunAllMacros()
Procedure1
Procedure2
MsgBox "Success!", 64
End Sub


Sub Procedure1()
Set objppt = CreateObject("PowerPoint.Application")
objppt.Visible = True
objppt.Presentations.Open "c:\pub\template2.pptm" ' your path here
End Sub


Sub Procedure2()
Dim rng As Range, mypres As PowerPoint.Presentation, sl As Object, _
myShape As Object, sar, i%, rad, wa, ha, tit, subtit, la, ta, tsl%, bl%
tsl = 1                                     ' title and subtitle layout
bl = 7                                      ' background layout for presentation body
la = Array(10, 20, 30, 40, 50, 60)          ' left
ta = Array(70, 75, 80, 85, 90, 95)          ' top
sar = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5", "Sheet6")
tit = Array("title1", "title2", "title3", "title4", "title5", "title6")
subtit = Array("subtitle1", "subtitle2", "subtitle3", "subtitle4", "subtitle5", "subtitle6")
rad = Array("B7:T33", "B7:K33", "B3:P39", "B3:P39", "B3:P39", "B2:P36") ' ranges
wa = Array(0.8, 0.8, 0.9, 0.9, 0.9, 0.9)    ' percentages of slide width and height
ha = Array(0.8, 0.8, 0.8, 0.8, 0.8, 0.8)
Set mypres = objppt.ActivePresentation
Do While mypres.Slides.Count > 1
    mypres.Slides(mypres.Slides.Count).Delete
Loop
Set sl = objppt.ActiveWindow.View.Slide
sl.CustomLayout = mypres.Designs(1).SlideMaster.CustomLayouts(tsl)
For i = LBound(sar) To UBound(sar)
    sl.Shapes(1).TextFrame.TextRange.Text = tit(i)
    sl.Shapes(1).TextFrame.VerticalAnchor = msoAnchorTop                ' #5
    sl.Shapes(2).TextFrame.TextRange.Text = subtit(i)
    sl.CustomLayout = mypres.Designs(1).SlideMaster.CustomLayouts(bl)
    With sl.Shapes(1)
        .TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignRight
        .Top = 7
        .Left = 63
    End With
    With sl.Shapes(2)
        .Top = sl.Shapes(1).Top + sl.Shapes(1).Height - 30              ' position subtitle
        .Left = 608
        .TextFrame.TextRange.Font.Color.RGB = RGB(250, 250, 250)
        .TextFrame.TextRange.Font.Italic = msoTrue                      ' #2
        .TextFrame.TextRange.ParagraphFormat.Bullet = msoFalse          ' #3
        .Width = mypres.PageSetup.SlideWidth * 0.8                      ' #4
    End With
    Set rng = ThisWorkbook.Sheets(sar(i)).Range(rad(i))
    rng.Copy
    sl.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
    Set myShape = sl.Shapes(sl.Shapes.Count)
    With myShape
        .LockAspectRatio = 0
        .Left = la(i)
        .Top = ta(i)
        .Width = wa(i) * mypres.PageSetup.SlideWidth                    ' set picture size
        .Height = ha(i) * mypres.PageSetup.SlideHeight
    End With
    Set sl = mypres.Slides.Add(mypres.Slides.Count + 1, ppLayoutTitle)  ' title and subtitle
Next
If mypres.Slides.Count > 3 Then mypres.Slides(mypres.Slides.Count).Delete
Set sl = mypres.Slides.Add(1, ppLayoutTitleOnly)
sl.CustomLayout = mypres.Designs(1).SlideMaster.CustomLayouts(tsl)        ' desired cover background
sl.Shapes(1).TextFrame.TextRange.Text = "Cover"
objppt.Visible = 1
objppt.Activate
Application.CutCopyMode = False ' clear clipboard
'mypres.SaveAs "c:\users\public\finaldeck.pptx"
End Sub

 

[onthegreen03]

Welcome back! Okay I ran the new code and on my end the results are still mixed. The second slide (first data slide) still has a slide number but now it has it for both title and subtitle boxes. In the previous code only the subtitle came in as a slide number box. For slides 3-7 the subtitle box looks good (I just need to reset the settings to get it placed correctly in the heading area). But the title box is now centered in the heading area and the box itself is more of a square shape as opposed to a long rectangle so that does not appear to be as desirable versus how it looked in the previous code. As you mentioned previously let me know if sending you my file is a next good step ... I'm thinking it might save you time vs. going back and forth trying to figure out my wacky layout. If that is indeed what you prefer just let me know which PP file you need. I'm assuming it is the .potx file that is part of the code but I want to make sure I send you what you need. Thanks.

 

[Worf]

New version:

Dim objppt As PowerPoint.Application
Sub RunAllMacros()
Procedure1
Procedure2
MsgBox "Success!", 64
End Sub


Sub Procedure1()
Set objppt = CreateObject("PowerPoint.Application")
objppt.Visible = True
objppt.Presentations.Open "c:\pub\blank2.pptm" ' your path here
End Sub


Sub Procedure2()
Dim rng As Range, mypres As PowerPoint.Presentation, sl As Object, _
myShape As Object, sar, i%, rad, wa, ha, tit, subtit, la, ta, tsl%, bl%
tsl = 1                                     ' title and subtitle layout
bl = 7                                      ' background layout for presentation body
la = Array(10, 20, 30, 40, 50, 60)          ' left
ta = Array(70, 75, 80, 85, 90, 95)          ' top
sar = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5", "Sheet6")
tit = Array("title1", "title2", "title3", "title4", "title5", "title6")
subtit = Array("subtitle1", "subtitle2", "subtitle3", "subtitle4", "subtitle5", "subtitle6")
rad = Array("B7:T33", "B7:K33", "B3:P39", "B3:P39", "B3:P39", "B2:P36") ' ranges
wa = Array(0.8, 0.8, 0.9, 0.9, 0.9, 0.9)    ' percentages of slide width and height
ha = Array(0.8, 0.8, 0.8, 0.8, 0.8, 0.8)
Set mypres = objppt.ActivePresentation
Do While mypres.Slides.Count > 1
    mypres.Slides(mypres.Slides.Count).Delete
Loop
Set sl = objppt.ActiveWindow.View.Slide
sl.CustomLayout = mypres.Designs(1).SlideMaster.CustomLayouts(tsl)
For i = LBound(sar) To UBound(sar)
    sl.Shapes(1).TextFrame.TextRange.Text = tit(i)
    sl.Shapes(1).TextFrame.VerticalAnchor = msoAnchorTop
    sl.Shapes(2).TextFrame.TextRange.Text = subtit(i)
    sl.Shapes(1).Name = "title"
    sl.Shapes(2).Name = "subtitle"
    sl.CustomLayout = mypres.Designs(1).SlideMaster.CustomLayouts(bl)
    For Each myShape In sl.Shapes
        If myShape.Name <> "title" And myShape.Name <> "subtitle" Then myShape.Delete
    Next
    With sl.Shapes(1)
        .TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignRight
        .Top = 7
        .Left = 10
        .Width = mypres.PageSetup.SlideWidth * 0.98
        .TextFrame.TextRange.Font.Size = 22
        .TextFrame.TextRange.Font.Color.RGB = RGB(250, 250, 250)
        .TextFrame.TextRange.Font.Bold = 1
    End With
    With sl.Shapes(2)
        .Top = sl.Shapes(1).Top + sl.Shapes(1).Height - 30              ' position subtitle
        .Left = 10
        .TextFrame.TextRange.Font.Color.RGB = RGB(250, 250, 250)
        .TextFrame.TextRange.Font.Italic = msoTrue
        .TextFrame.TextRange.ParagraphFormat.Bullet = msoFalse
        .Width = mypres.PageSetup.SlideWidth * 0.98
        .TextFrame.TextRange.Font.Size = 20
        .TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignRight
    End With
    Set rng = ThisWorkbook.Sheets(sar(i)).Range(rad(i))
    rng.Copy
    sl.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
    Set myShape = sl.Shapes(sl.Shapes.Count)
    With myShape
        .LockAspectRatio = 0
        .Left = la(i)
        .Top = ta(i)
        .Width = wa(i) * mypres.PageSetup.SlideWidth                    ' set picture size
        .Height = ha(i) * mypres.PageSetup.SlideHeight
    End With
    Set sl = mypres.Slides.Add(mypres.Slides.Count + 1, ppLayoutTitle)  ' title and subtitle
Next
If mypres.Slides.Count > 3 Then mypres.Slides(mypres.Slides.Count).Delete
Set sl = mypres.Slides.Add(1, ppLayoutTitleOnly)
sl.CustomLayout = mypres.Designs(1).SlideMaster.CustomLayouts(tsl)        ' desired cover background
sl.Shapes(1).TextFrame.TextRange.Text = "Spiffy Medical"
sl.Shapes(2).TextFrame.TextRange.Text = "Third Quarter Results"
objppt.Visible = 1
objppt.Activate
Application.CutCopyMode = False ' clear clipboard
'mypres.SaveAs "c:\users\public\finaldeck.pptx"
End Sub

 

[onthegreen03]

Worf -

Oh so close! All of the data slides look GREAT except that first data slide (first slide after the cover page).

Here is what I am seeing on that first data slide:

1. The title placement is perfect (top right aligned) but the word "Title" is not bold and is italicized. Font size is only 20 (on the other slides the title font is 22). What is weird is the number 2 is bold and has the correct font size. It looks like this: Title2 (not to scale ... just for illustration purposes)

2. The subtitle box still has a bullet point and is placed down in the middle (left hand side) of the actual slide. Font size is 18 with no bold or italics.

3. The rest of the data slides look perfect. Title and subtitle positioned correctly. Entire title text is 22 font and bold (would prefer 24 but 22 works too). Subtitle text is 20 font and italicized. Perfect!

4. Cover page looks good also. Title and subtitle coming in ... love the Spiffy Medical reference!

Let me know if you need anything else from me. Hopefully this is descriptive enough. It's just that first data slide .... everything else looks good at first glance but I'll give it another once over and will post again later if I see anything else.

As always if you get sick of working on this for me just let me know. I know you've spent a lot of time on this and I appreciate it.

 

[onthegreen03]

Worf -

I took another look at that first data slide and have an update. The "Title1" box is positioned correctly but it's coming in with 20 font and italics. There is a bold "2" sitting above the 1 in "Title1" which was why I thought it read "title2". There is a second box sitting on top with the number 2 in there ... I am assuming that is the slide number since it is the second slide in the deck. Weird. As mentioned before the subtitle box is showing up in the middle of the slide with a bullet, font size 18 and not italicized. The subtitles should not be bolded so we are good there. All of the other data slides look perfect.

Thanks.

 

[Worf]

Hi

- You can easily change the font size on the code.
- New version below:

Dim objppt As PowerPoint.Application
Sub RunAllMacros()
Procedure1
Procedure2
MsgBox "Success!", 64
End Sub


Sub Procedure1()
Set objppt = CreateObject("PowerPoint.Application")
objppt.Visible = True
objppt.Presentations.Open "c:\pub\blank2.pptm" ' your path here
End Sub


Sub Procedure2()
Dim rng As Range, mypres As PowerPoint.Presentation, sl As Object, _
shp As Object, sar, i%, rad, wa, ha, tit, subtit, la, ta, tsl%, bl%
tsl = 1                                     ' title and subtitle layout
bl = 7                                      ' background layout for presentation body
la = Array(10, 20, 30, 40, 50, 60)          ' left
ta = Array(70, 75, 80, 85, 90, 95)          ' top
sar = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5", "Sheet6")
tit = Array("title1", "title2", "title3", "title4", "title5", "title6")
subtit = Array("subtitle1", "subtitle2", "subtitle3", "subtitle4", "subtitle5", "subtitle6")
rad = Array("B7:T33", "B7:K33", "B3:P39", "B3:P39", "B3:P39", "B2:P36") ' ranges
wa = Array(0.8, 0.8, 0.9, 0.9, 0.9, 0.9)    ' percentages of slide width and height
ha = Array(0.8, 0.8, 0.8, 0.8, 0.8, 0.8)
Set mypres = objppt.ActivePresentation
Do While mypres.Slides.Count > 1
    mypres.Slides(mypres.Slides.Count).Delete
Loop
Set sl = objppt.ActiveWindow.View.Slide
sl.CustomLayout = mypres.Designs(1).SlideMaster.CustomLayouts(tsl)
For i = LBound(sar) To UBound(sar)
    sl.Shapes(1).Name = "title"
    sl.Shapes(2).Name = "subtitle"
    For Each shp In sl.Shapes
        If shp.Name <> "title" And shp.Name <> "subtitle" Then shp.Delete
    Next
    sl.Shapes(1).TextFrame.TextRange.Text = tit(i)
    sl.Shapes(1).TextFrame.VerticalAnchor = msoAnchorTop
    sl.Shapes(2).TextFrame.TextRange.Text = subtit(i)
    sl.CustomLayout = mypres.Designs(1).SlideMaster.CustomLayouts(bl)
    With sl.Shapes(1)
        .TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignRight
        .Top = 7
        .Left = 10
        .Width = mypres.PageSetup.SlideWidth * 0.98
        .TextFrame.TextRange.Font.Size = 22
        .TextFrame.TextRange.Font.Color.RGB = RGB(250, 250, 250)
        .TextFrame.TextRange.Font.Bold = 1
    End With
    With sl.Shapes(2)
        .Top = sl.Shapes(1).Top + sl.Shapes(1).Height - 30              ' position subtitle
        .Left = 10
        .TextFrame.TextRange.Font.Color.RGB = RGB(250, 250, 250)
        .TextFrame.TextRange.Font.Italic = msoTrue
        .TextFrame.TextRange.ParagraphFormat.Bullet = msoFalse
        .Width = mypres.PageSetup.SlideWidth * 0.98
        .TextFrame.TextRange.Font.Size = 20
        .TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignRight
    End With
    Set rng = ThisWorkbook.Sheets(sar(i)).Range(rad(i))
    rng.Copy
    sl.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
    Set shp = sl.Shapes(sl.Shapes.Count)
    With shp
        .LockAspectRatio = 0
        .Left = la(i)
        .Top = ta(i)
        .Width = wa(i) * mypres.PageSetup.SlideWidth                    ' set picture size
        .Height = ha(i) * mypres.PageSetup.SlideHeight
    End With
    Set sl = mypres.Slides.Add(mypres.Slides.Count + 1, ppLayoutTitle)  ' title and subtitle
Next
If mypres.Slides.Count > 3 Then mypres.Slides(mypres.Slides.Count).Delete
Set sl = mypres.Slides.Add(1, ppLayoutTitleOnly)
sl.CustomLayout = mypres.Designs(1).SlideMaster.CustomLayouts(tsl)        ' desired cover background
sl.Shapes(1).TextFrame.TextRange.Text = "Spiffy Medical"
sl.Shapes(2).TextFrame.TextRange.Text = "Third Quarter Results"
objppt.Visible = 1
objppt.Activate
Application.CutCopyMode = False ' clear clipboard
'mypres.SaveAs "c:\users\public\finaldeck.pptx"
End Sub

 

[onthegreen03]

Hi Worf - I tried the new code and still the same problem. Cover slide (slide 1) looks great. Data slides (slides 3-7) all look great. That first data slide (slide 2 in the deck) is still not showing the correct title and subtitle boxes. "Title1" is smaller font, not bolded and is italicized ... the placement is okay but not as good as the other data slide titles. The subtitle box still has a bullet point, black font and is placed in the middle of the slide (to the left). There is a third box as mentioned before with a "2" inside of it, presumably a slide # box. That is sitting right below the "Title" box. If it helps I can send you the resulting PP deck so you can see the results for yourself. This is so weird because the other slides are nearly perfect ... it's just that first data slide (slide 2). Please let me know if you need anything from me and thanks for continuing to work on this. I hope you're not ready to give up!

 

[Worf]

I am not able to reproduce the issue, but I believe it’s happening as you describe.
Maybe this one?

Dim objppt As PowerPoint.Application, rng As Range, mypres As PowerPoint.Presentation, sl As Object, _
shp As Object, sar, i%, rad, wa, ha, tit, subtit, la, ta, tsl%, bl%


Sub RunAllMacros()
Procedure1
Procedure2
MsgBox "Success!", 64
End Sub


Sub Procedure1()
Set objppt = CreateObject("PowerPoint.Application")
objppt.Visible = True
objppt.Presentations.Open "c:\pub\blank2.pptm" ' your path here
End Sub


Sub Procedure2()
tsl = 1                                     ' title and subtitle layout
bl = 7                                      ' background layout for presentation body
la = Array(10, 20, 30, 40, 50, 60)          ' left
ta = Array(70, 75, 80, 85, 90, 95)          ' top
sar = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5", "Sheet6")
tit = Array("title1", "title2", "title3", "title4", "title5", "title6")
subtit = Array("subtitle1", "subtitle2", "subtitle3", "subtitle4", "subtitle5", "subtitle6")
rad = Array("B7:T33", "B7:K33", "B3:P39", "B3:P39", "B3:P39", "B2:P36") ' ranges
wa = Array(0.8, 0.8, 0.9, 0.9, 0.9, 0.9)    ' percentages of slide width and height
ha = Array(0.8, 0.8, 0.8, 0.8, 0.8, 0.8)
Set mypres = objppt.ActivePresentation
Do While mypres.Slides.Count > 1
    mypres.Slides(mypres.Slides.Count).Delete
Loop
Set sl = objppt.ActiveWindow.View.Slide
sl.CustomLayout = mypres.Designs(1).SlideMaster.CustomLayouts(tsl)
For i = LBound(sar) To UBound(sar)
    FormatSlide (i + 1)
    Set rng = ThisWorkbook.Sheets(sar(i)).Range(rad(i))
    rng.Copy
    sl.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
    Set shp = sl.Shapes(sl.Shapes.Count)
    With shp
        .Name = "sheetrange"
        .LockAspectRatio = 0
        .Left = la(i)
        .Top = ta(i)
        .Width = wa(i) * mypres.PageSetup.SlideWidth                        ' set picture size
        .Height = ha(i) * mypres.PageSetup.SlideHeight
    End With
    Set sl = mypres.Slides.Add(mypres.Slides.Count + 1, ppLayoutTitle)      ' title and subtitle
Next
If mypres.Slides.Count > 3 Then mypres.Slides(mypres.Slides.Count).Delete
FormatSlide 1                                                               ' first one, again
Set sl = mypres.Slides.Add(1, ppLayoutTitleOnly)
sl.CustomLayout = mypres.Designs(1).SlideMaster.CustomLayouts(tsl)          ' desired cover background
sl.Shapes(1).TextFrame.TextRange.Text = "Spiffy Medical"
sl.Shapes(2).TextFrame.TextRange.Text = "Third Quarter Results"
objppt.Visible = 1: objppt.Activate
Application.CutCopyMode = False
'mypres.SaveAs "c:\users\public\finaldeck.pptx"
End Sub


Sub FormatSlide(sn)
Set sl = mypres.Slides(sn)
MsgBox "Formatting slide " & sn & " of " & mypres.Slides.Count, 64, "Data Slides"
sl.Shapes(1).Name = "title"
sl.Shapes(2).Name = "subtitle"
For Each shp In sl.Shapes
    If shp.Name <> "title" And shp.Name <> "subtitle" And shp.Name <> "sheetrange" Then shp.Delete
Next
sl.Shapes(1).TextFrame.TextRange.Text = tit(sn - 1)
sl.Shapes(1).TextFrame.VerticalAnchor = msoAnchorTop
sl.Shapes(2).TextFrame.TextRange.Text = subtit(sn - 1)
sl.CustomLayout = mypres.Designs(1).SlideMaster.CustomLayouts(bl)
With sl.Shapes(1)
    .TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignRight
    .Top = 7
    .Left = 10
    .Width = mypres.PageSetup.SlideWidth * 0.98
    .TextFrame.TextRange.Font.Size = 22
    .TextFrame.TextRange.Font.Color.RGB = RGB(250, 250, 250)
    .TextFrame.TextRange.Font.Bold = 1
End With
With sl.Shapes(2)
    .Top = sl.Shapes(1).Top + sl.Shapes(1).Height - 30              ' position subtitle
    .Left = 10
    .TextFrame.TextRange.Font.Color.RGB = RGB(250, 250, 250)
    .TextFrame.TextRange.Font.Italic = msoTrue
    .TextFrame.TextRange.ParagraphFormat.Bullet = msoFalse
    .Width = mypres.PageSetup.SlideWidth * 0.98
    .TextFrame.TextRange.Font.Size = 20
    .TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignRight
End With
End Sub

 

[onthegreen03]

Hi Worf -

Okay, slightly different results. The cover slide and data slides 3-7 are all still perfect, but Slide 2 (first data slide) is still a bit weird.

1. There are now "Title" and "Subtitle" boxes in the heading but the subtitle box is above the title box (hanging off of the slide a bit). The color and text formats all look good. But in data slides 3-7 the placement of the title and subtitle boxes is nearly perfect so I'm still not sure why slide 2 is not formatting like those other slides. I guess if we can get the subtitle box to drop below the title box all will be good. However it would be great if we can get slide 2 to set up the same way as the other data slides.

2. The only other thing is there is still a second subtitle box sitting in the middle of slide 2 (black font with bullet point). Can you make that disappear?

3. Lastly, unrelated to formatting. When I run the macro now I get multiple mag boxes that pop up and say "Formatting Slide 1 of 1, 2 of 2 , etc. all the way up to 6 of 6. I need to click OK in those boxes before the macro will finish. Any way we can get rid of that extra process?

Thanks as always!

 

[Worf]

I reproduced the issue and apparently corrected it:

Dim objppt As PowerPoint.Application, rng As Range, mypres As Presentation, sl As Object, _
shp As Object, sar, i%, rad, wa, ha, tit, subtit, la, ta, tsl%, bl%


Sub RunAllMacros()
Procedure1
Procedure2
MsgBox "Success!", 64
End Sub


Sub Procedure1()
Set objppt = CreateObject("PowerPoint.Application")
objppt.Visible = True
objppt.Presentations.Open "c:\pub\blank.potx" ' your path here
End Sub


Sub Procedure2()
tsl = 1                                     ' title and subtitle layout
bl = 7                                      ' background layout for presentation body
la = Array(10, 20, 30, 40, 50, 60)          ' left
ta = Array(70, 75, 80, 85, 90, 95)          ' top
sar = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5", "Sheet6")
tit = Array("title1", "title2", "title3", "title4", "title5", "title6")
subtit = Array("subtitle1", "subtitle2", "subtitle3", "subtitle4", "subtitle5", "subtitle6")
rad = Array("B7:T33", "B7:K33", "B3:P39", "B3:P39", "B3:P39", "B2:P36") ' ranges
wa = Array(0.8, 0.8, 0.9, 0.9, 0.9, 0.9)    ' percentages of slide width and height
ha = Array(0.8, 0.8, 0.8, 0.8, 0.8, 0.8)
Set mypres = objppt.ActivePresentation
Do While mypres.Slides.Count > 1
    mypres.Slides(mypres.Slides.Count).Delete
Loop
Set sl = objppt.ActiveWindow.View.Slide
sl.CustomLayout = mypres.Designs(1).SlideMaster.CustomLayouts(tsl)
For i = LBound(sar) To UBound(sar)
    FormatSlide (i + 1)
    Set rng = ThisWorkbook.Sheets(sar(i)).Range(rad(i))
    rng.Copy
    sl.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
    Set shp = sl.Shapes(sl.Shapes.Count)
    With shp
        .Name = "sheetrange"
        .LockAspectRatio = 0
        .Left = la(i)
        .Top = ta(i)
        .Width = wa(i) * mypres.PageSetup.SlideWidth                        ' set picture size
        .Height = ha(i) * mypres.PageSetup.SlideHeight
    End With
    Set sl = mypres.Slides.Add(mypres.Slides.Count + 1, ppLayoutTitle)      ' title and subtitle
Next
If mypres.Slides.Count > 3 Then mypres.Slides(mypres.Slides.Count).Delete
Set sl = mypres.Slides.Add(1, ppLayoutTitleOnly)
sl.CustomLayout = mypres.Designs(1).SlideMaster.CustomLayouts(tsl)          ' desired cover background
sl.Shapes(1).TextFrame.TextRange.Text = "Spiffy Medical"
sl.Shapes(2).TextFrame.TextRange.Text = "Third Quarter Results"
objppt.Visible = 1: objppt.Activate
Application.CutCopyMode = False
'mypres.SaveAs "c:\users\public\finaldeck.pptx"
End Sub


Sub FormatSlide(sn)
Set sl = mypres.Slides(sn)
Do While sl.Shapes.Count > 2
    sl.Shapes(sl.Shapes.Count).Delete
Loop
sl.Shapes(1).Name = "_title"
sl.Shapes(2).Name = "sub_title"
sl.Shapes(1).TextFrame.TextRange.Text = tit(sn - 1)
sl.Shapes(1).TextFrame.VerticalAnchor = msoAnchorTop
sl.Shapes(2).TextFrame.TextRange.Text = subtit(sn - 1)
sl.CustomLayout = mypres.Designs(1).SlideMaster.CustomLayouts(bl)
With sl.Shapes(1)
    .TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignRight
    .Top = 7
    .Left = 10
    .Width = mypres.PageSetup.SlideWidth * 0.98
    .TextFrame.TextRange.Font.Size = 22
    .TextFrame.TextRange.Font.Color.RGB = RGB(250, 250, 250)
    .TextFrame.TextRange.Font.Bold = 1
End With
With sl.Shapes(2)
    .Top = sl.Shapes(1).Top + sl.Shapes(1).Height - 30              ' position subtitle
    .Left = 10
    .TextFrame.TextRange.Font.Color.RGB = RGB(250, 250, 250)
    .TextFrame.TextRange.Font.Italic = msoTrue
    .TextFrame.TextRange.ParagraphFormat.Bullet = msoFalse
    .Width = mypres.PageSetup.SlideWidth * 0.98
    .TextFrame.TextRange.Font.Size = 20
    .TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignRight
End With
End Sub