Excel to PowerPoint VBA - Need help diagnosing and fixing error in code

[onthegreen03]

Hi - I worked with a VBA expert @Worf on this board several years ago and eventually came up with the code below which auto copied charts/graphs from multiple Excel tabs to PowerPoint. It was a little messy but it worked perfectly. I am now trying to copy that same code into a new file but when I try running it stops on the line highlighted below. It worked a few years ago in a different file but now does not work. Can someone help me figure out how to get this moving again?

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

Sub Procedure1()
'
Set objppt = CreateObject("PowerPoint.Application")
objppt.Visible = True
objppt.Presentations.Open "C:\USERS\me\Blank.potx" ' your path here
End Sub

Sub Procedure2()
'
tsl = 1 ' title and subtitle layout
bl = 7 ' background layout for presentation body
la = Array(70, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10) ' left
ta = Array(90, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105) ' top
sar = Array("(7)", "(8)", "(9)", "(10)", "(11)", "(12)", "(14)", "(15)", "(16)", "(17)", "(18)")
rad = Array("B2:T49", "A15:Ac56", "A15:Ac56", "A15:Ac56", "A15:Ac56", "A15:Ac56", "A15:Ac56", "A15:Ac56", "A15:Ac56", "A15:Ac56", "A15:Ac56") ' ranges
wa = Array(0.8, 0.98, 0.98, 0.98, 0.98, 0.98, 0.98, 0.98, 0.98, 0.98, 0.98) ' percentages of slide width and height
ha = Array(0.75, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7)
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 = "US HEM/ONC Franchise Performance Update"
sl.Shapes(2).TextFrame.TextRange.Text = DateTime.Date
sl.Shapes(3).Delete ' slide number
objppt.Visible = 1: objppt.Activate
Application.CutCopyMode = False
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 = Sheets("Titles").[a1].Offset(sn - 1)
sl.Shapes(1).TextFrame.VerticalAnchor = msoAnchorTop
sl.Shapes(2).TextFrame.TextRange.Text = Sheets("Titles").[b1].Offset(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
sl.Shapes.AddShape msoShapeRectangle, 50, 50, 20, 15
With sl.Shapes(3)
.Top = mypres.PageSetup.SlideHeight - 20
.Left = 10
.TextFrame.TextRange.Font.Color.RGB = RGB(1, 2, 3)
.Fill.Visible = msoFalse
.Line.ForeColor.RGB = RGB(250, 250, 250)
.TextFrame.TextRange.InsertSlideNumber
.TextFrame.TextRange.Font.Size = 8
.TextFrame.TextRange.Font.Italic = msoTrue
End With
End Sub

 

[Micron]

I guess I didn't know that because it comes from Visual Basic and just happens to work in VBA as well (as do many VB things). I think I will stick with the other way though. In case anyone reading this in the future wants to see what the other characters are:

Type Characters - Visual Basic

Learn more about: Type characters (Visual Basic)

docs.microsoft.com

 

[Worf]

Here is what I have so far:

Dim thisDate As Date, objppt As PowerPoint.Application, rng As Range, mypres As Presentation, sl As Object, _
shp As Object, sar, i%, rad, wa, ha, 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 "d:\test\Blank3.potx"       ' your path here
End Sub

Sub Procedure2()
Dim k%
tsl = 1                                     ' title and subtitle layout
bl = 14                                      ' background layout for presentation body
la = Array(70, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10)          ' left
ta = Array(90, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105)          ' top
sar = Array("(7)", "(8)", "(9)", "(10)", "(11)", "(12)", "(14)", "(15)", "(16)", "(17)", "(18)")
rad = Array("B2:T49", "A15:Ac56", "A1:q50", "A1:h25", "A15:Ac56", "A1:h20", "A1:x35", "A15:Ac56", "A15:Ac56", "A15:Ac56", "A15:Ac56")
wa = Array(0.8, 0.98, 0.98, 0.98, 0.98, 0.98, 0.98, 0.98, 0.98, 0.98, 0.98) ' percentages of slide width and height
ha = Array(0.75, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7)
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
    For k = 1 To 10
        DoEvents
    Next
    Application.Wait Now + #12:00:03 AM#
    sl.Shapes.PasteSpecial DataType:=ppPasteBitmap
    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(2).TextFrame.TextRange.Text = "Product Performance Update"
sl.Shapes(1).TextFrame.TextRange.Text = DateTime.Date
If sl.Shapes.Count = 3 Then sl.Shapes(3).Delete                             ' slide number
objppt.Visible = 1: objppt.Activate
Application.CutCopyMode = False
End Sub

Sub FormatSlide(sn)
Dim j%
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 = Sheets("Titles").[a1].Offset(sn - 1)
sl.Shapes(1).TextFrame.VerticalAnchor = msoAnchorTop
sl.Shapes(2).TextFrame.TextRange.Text = Sheets("Titles").[b1].Offset(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(1, 2, 3)
    .TextFrame.TextRange.Font.Bold = 1
End With
With sl.Shapes(2)
    .Top = sl.Shapes(1).Top + sl.Shapes(1).Height               ' position subtitle
    .Left = 10
    .TextFrame.TextRange.Font.Color.RGB = RGB(1, 2, 3)
    .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
For j = sl.Shapes.Count To 1 Step -1
    If sl.Shapes(j).Name Like "Rect*" Or sl.Shapes(j).Name Like "*Title*" Then sl.Shapes(j).Delete
Next
sl.Shapes("_title").Top = 7
End Sub

 

[onthegreen03]

Thanks Worf, getting much closer. The code runs all the way through and the title slide looks great, no issues there. In the body of the PowerPoint the title and subtitle boxes on slides 3-12 are positioned perfectly (title on top, subtitle below), however I did change the code so the text is aligned to the left not right.

I jotted down the remaining few/small issues that I saw, you probably see the same things on your end. First, the subtitle boxes are coming in much larger than the actual text. Is there a way to auto-size the text box based on the text size? Also, the title and subtitle boxes on slide 2 are different from the other slides. Can you copy the same format from slides 3-12 (once fixed) to slide 2 so they all look the same?

Lastly, I would like the text size for the titles to be 24 (not 22), and for the subtitles to be 18 (not 20). I changed it on my end but wanted to point that out so you can update the code on your end in case it matters for the text box sizing. Thanks again for working on this, very much appreciated!!

 

[Worf]

Do you want to adjust the text box width also or just its height?

 

[onthegreen03]

Do you want to adjust the text box width also or just its height?

You can leave the width so it goes across the entire top of slide. Thanks!

 

[Worf]

I left the line that reduces the title's width, in case someone else needs it.

Dim thisDate As Date, objppt As PowerPoint.Application, rng As Range, mypres As Presentation, sl As Object, _
shp As Object, sar, i%, rad, wa, ha, 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 "d:\test\Blank3.potx"       ' your path here
End Sub

Sub Procedure2()
Dim k%
tsl = 1                                     ' title and subtitle layout
bl = 14                                      ' background layout for presentation body
la = Array(70, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10)          ' left
ta = Array(90, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105)          ' top
sar = Array("(7)", "(8)", "(9)", "(10)", "(11)", "(12)", "(14)", "(15)", "(16)", "(17)", "(18)")
rad = Array("B2:T49", "A15:Ac56", "A1:q50", "A1:h25", "A15:Ac56", "A1:h20", "A1:x35", "A15:Ac56", "A15:Ac56", "A15:Ac56", "A15:Ac56")
wa = Array(0.8, 0.98, 0.98, 0.98, 0.98, 0.98, 0.98, 0.98, 0.98, 0.98, 0.98) ' percentages of slide width and height
ha = Array(0.75, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7)
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
    For k = 1 To 10
        DoEvents
    Next
    Application.Wait Now + #12:00:03 AM#
    sl.Shapes.PasteSpecial DataType:=ppPasteBitmap
    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(2).TextFrame.TextRange.Text = "Product Performance Update"
sl.Shapes(1).TextFrame.TextRange.Text = DateTime.Date
If sl.Shapes.Count = 3 Then sl.Shapes(3).Delete                             ' slide number
objppt.Visible = 1: objppt.Activate
Application.CutCopyMode = False
End Sub

Sub FormatSlide(sn)
Dim j%
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 = Sheets("Titles").[a1].Offset(sn - 1)
sl.Shapes(1).TextFrame.VerticalAnchor = msoAnchorTop
sl.Shapes(2).TextFrame.TextRange.Text = Sheets("Titles").[b1].Offset(sn - 1)
sl.CustomLayout = mypres.Designs(1).SlideMaster.CustomLayouts(bl)
With sl.Shapes(2)
    .Top = sl.Shapes(1).Top + sl.Shapes(1).Height               ' position subtitle
    .Left = 10
    .TextFrame.TextRange.Font.Color.RGB = RGB(1, 2, 3)
    .TextFrame.TextRange.Font.Italic = msoTrue
    .TextFrame.TextRange.ParagraphFormat.Bullet = msoFalse
    .TextFrame.TextRange.Font.Size = 18
    .TextFrame.AutoSize = ppAutoSizeShapeToFitText
    .TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft
End With
For j = sl.Shapes.Count To 1 Step -1
    If sl.Shapes(j).Name Like "Rect*" Or sl.Shapes(j).Name Like "*Title*" Then sl.Shapes(j).Delete
Next
With sl.Shapes("_title")
    .TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft
    .Top = 7
    .Left = 10
    .TextFrame.TextRange.Font.Size = 23
    .TextFrame.TextRange.Font.Color.RGB = RGB(1, 2, 3)
    .TextFrame.TextRange.Font.Bold = 1
    .TextFrame.TextRange.ParagraphFormat.Bullet = msoFalse
    .Width = Len(.TextFrame.TextRange.Text) * mypres.PageSetup.SlideWidth / _
    (1782.1 * (.TextFrame.TextRange.Font.Size) ^ -1.018)
End With
End Sub
' ******************

 

[onthegreen03]

Thanks Worf. I’ll load and test tomorrow. A big thanks for your work on this!

 

[onthegreen03]

Hi Worf - I tested the latest code this morning and it looked/worked great. I have one additional ask which should be my last. In the body slides the subtitle box is not pasting directly below the title box. Can you adjust the code so the subtitle box is directly beneath the title box? Right now it drops it down about 2 inches or so. Also, one additional small thing so no need to change if too much work .... on slide 2 the title box is being copied slightly higher on the slide vs the other slides (3-12). Is there an easy way to tweak the placement of the title box placement on slide 2 so it aligns with the other slides? THANK YOU again for working on this, I think a lot of folks here will find this very useful. I know I will.

 

[onthegreen03]

Hi Worf - I actually fixed the placement of the subtitle box so I am all good there; I will paste my updated code below so you can see what I did.

The only two remaining (minor) issues are:

1. Slide 2 title box is pasting slightly higher vs. the title boxes on slides 3-12. Can you align the placement of the title box on all body slides (2-12)? I looked at the code and could not figure out how to fix that small issue.
2. See the PP slide screen shots below. The first one is from the current code, and as you can see the title and subtitle boxes do not stretch across the entire length of the slide, causing the subtitle box to wrap text. The second one is how I would like the boxes to be sized, with the entire box stretched across the top to avoid wrapping text.

Thanks for your continued help!

New code with subtitle placement changed:

Dim thisDate As Date, objppt As PowerPoint.Application, rng As Range, mypres As Presentation, sl As Object, _
shp As Object, sar, i%, rad, wa, ha, 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:\USERS\me\Blank3.potx"       ' your path here
End Sub
Sub Procedure2()
Dim k%
tsl = 1                                     ' title and subtitle layout
bl = 14                                      ' background layout for presentation body
la = Array(70, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10)          ' left
ta = Array(90, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105)          ' top
sar = Array("(7)", "(8)", "(9)", "(10)", "(11)", "(12)", "(14)", "(15)", "(16)", "(17)", "(18)")    'tab names
rad = Array("B2:T49", "A15:Ac56", "A1:q50", "A1:h25", "A15:Ac56", "A1:h20", "A1:x35", "A15:Ac56", "A15:Ac56", "A15:Ac56", "A15:Ac56")   ' range in Excel to copy (by tab)
wa = Array(0.8, 0.98, 0.98, 0.98, 0.98, 0.98, 0.98, 0.98, 0.98, 0.98, 0.98) ' percentages of slide width and height
ha = Array(0.75, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7)
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
    For k = 1 To 10
        DoEvents
    Next
    Application.Wait Now + #12:00:03 AM#
    sl.Shapes.PasteSpecial DataType:=ppPasteBitmap
    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(2).TextFrame.TextRange.Text = "Product Performance Update"
sl.Shapes(1).TextFrame.TextRange.Text = DateTime.Date
If sl.Shapes.Count = 3 Then sl.Shapes(3).Delete                             ' slide number
objppt.Visible = 1: objppt.Activate
Application.CutCopyMode = False
End Sub
Sub FormatSlide(sn)
Dim j%
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 = Sheets("Titles").[a1].Offset(sn - 1)
sl.Shapes(1).TextFrame.VerticalAnchor = msoAnchorTop
sl.Shapes(2).TextFrame.TextRange.Text = Sheets("Titles").[b1].Offset(sn - 1)
sl.CustomLayout = mypres.Designs(1).SlideMaster.CustomLayouts(bl)
With sl.Shapes(2)
    .Top = 33              ' position subtitle
    .Left = 10
    .TextFrame.TextRange.Font.Color.RGB = RGB(1, 2, 3)
    .TextFrame.TextRange.Font.Italic = msoTrue
    .TextFrame.TextRange.ParagraphFormat.Bullet = msoFalse
    .TextFrame.TextRange.Font.Size = 18
    .TextFrame.AutoSize = ppAutoSizeShapeToFitText
    .TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft
End With
For j = sl.Shapes.Count To 1 Step -1
    If sl.Shapes(j).Name Like "Rect*" Or sl.Shapes(j).Name Like "*Title*" Then sl.Shapes(j).Delete
Next
With sl.Shapes("_title")
    .TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft
    .Top = 7
    .Left = 10
    .TextFrame.TextRange.Font.Size = 23
    .TextFrame.TextRange.Font.Color.RGB = RGB(1, 2, 3)
    .TextFrame.TextRange.Font.Bold = 1
    .TextFrame.TextRange.ParagraphFormat.Bullet = msoFalse
    .Width = Len(.TextFrame.TextRange.Text) * mypres.PageSetup.SlideWidth / _
    (1782.1 * (.TextFrame.TextRange.Font.Size) ^ -1.018)
End With
End Sub

 

[Worf]

New version:

Dim thisDate As Date, objppt As PowerPoint.Application, rng As Range, mypres As Presentation, sl As Object, _
shp As Object, sar, i%, rad, wa, ha, 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 "d:\test\Blank3.potx"       ' your path here
End Sub

Sub Procedure2()
Dim k%
tsl = 1                                     ' title and subtitle layout
bl = 14                                      ' background layout for presentation body
la = Array(70, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10)          ' left
ta = Array(90, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105)          ' top
sar = Array("(7)", "(8)", "(9)", "(10)", "(11)", "(12)", "(14)", "(15)", "(16)", "(17)", "(18)")    'tab names
rad = Array("B2:T49", "A15:Ac56", "A1:q50", "A1:h25", "A15:Ac56", "A1:h20", _
"A1:x35", "A15:Ac56", "A15:Ac56", "A15:Ac56", "A15:Ac56")   ' range in Excel to copy (by tab)
wa = Array(0.8, 0.98, 0.98, 0.98, 0.98, 0.98, 0.98, 0.98, 0.98, 0.98, 0.98) ' percentages of slide width and height
ha = Array(0.75, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7)
Set mypres = objppt.ActivePresentation
Do While mypres.Slides.Count > 1
    mypres.Slides(mypres.Slides.Count).Delete
Loop
Set sl = mypres.Slides.Add(mypres.Slides.Count + 1, ppLayoutTitle)
mypres.Slides(1).Delete
Set sl = objppt.ActiveWindow.View.Slide
For i = LBound(sar) To UBound(sar)
    FormatSlide (i + 1)
    Set rng = ThisWorkbook.Sheets(sar(i)).Range(rad(i))
    rng.Copy
    For k = 1 To 10
        DoEvents
    Next
    Application.Wait Now + #12:00:03 AM#
    sl.Shapes.PasteSpecial DataType:=ppPasteBitmap
    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(2).TextFrame.TextRange.Text = "Product Performance Update"
sl.Shapes(1).TextFrame.TextRange.Text = DateTime.Date
If sl.Shapes.Count = 3 Then sl.Shapes(3).Delete                             ' slide number
objppt.Visible = 1: objppt.Activate
Application.CutCopyMode = False
End Sub

Sub FormatSlide(sn)
Dim j%
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 = Sheets("Titles").[a1].Offset(sn - 1)
sl.Shapes(1).TextFrame.VerticalAnchor = msoAnchorTop
sl.Shapes(2).TextFrame.TextRange.Text = Sheets("Titles").[b1].Offset(sn - 1)
sl.CustomLayout = mypres.Designs(1).SlideMaster.CustomLayouts(bl)
With sl.Shapes(2)
    .Top = 33              ' position subtitle
    .Left = 10
    .TextFrame.TextRange.Font.Color.RGB = RGB(1, 2, 3)
    .TextFrame.TextRange.Font.Italic = msoTrue
    .TextFrame.TextRange.ParagraphFormat.Bullet = msoFalse
    .TextFrame.TextRange.Font.Size = 18
    .TextFrame.AutoSize = ppAutoSizeShapeToFitText
    .Width = mypres.PageSetup.SlideWidth * 0.98
    .TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft
End With
For j = sl.Shapes.Count To 1 Step -1
    If sl.Shapes(j).Name Like "Rect*" Or sl.Shapes(j).Name Like "*Title*" Then sl.Shapes(j).Delete
Next
With sl.Shapes("_title")
    .TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft
    .Top = 7
    .Left = 10
    .TextFrame.TextRange.Font.Size = 23
    .TextFrame.TextRange.Font.Color.RGB = RGB(1, 2, 3)
    .TextFrame.TextRange.Font.Bold = 1
    .TextFrame.TextRange.ParagraphFormat.Bullet = msoFalse
    .Width = mypres.PageSetup.SlideWidth * 0.98
End With
End Sub