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

O

onthegreen03

Board Regular
Joined
Jun 30, 2016
Messages
148
Office Version
  1. 365
Platform
  1. Windows
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
 
Last edited:
Sort by date Sort by votes
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:
docs.microsoft.com

Type Characters - Visual Basic

Learn more about: Type characters (Visual Basic)
docs.microsoft.com
 
Upvote 0

Excel Facts

Excel Wisdom
Using a mouse in Excel is the work equivalent of wearing a lanyard when you first get to college
Here is what I have so far:

VBA Code: 
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
 
Upvote 0
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!!
 
Upvote 0
I left the line that reduces the title's width, in case someone else needs it.

VBA Code: 
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
' ******************
 
Upvote 0
Thanks Worf. I’ll load and test tomorrow. A big thanks for your work on this!
 
Upvote 0
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.
 
Upvote 0
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.

1648061108338.png


1648061121580.png


Thanks for your continued help!

New code with subtitle placement changed:

VBA Code: 
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
 
Last edited:
Upvote 0
New version:

VBA Code: 
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
 
Upvote 0
Solution
You must log in or register to reply here.

Forum statistics

Threads
1,214,952
Messages
6,122,458
Members
449,085
Latest member
ExcelError

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top