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]

Indicating which line causes an error is great. Not providing the error number or message - not so much. IMO, most of the time the best you can expect to get is a shot in the dark like this one: Declare your variables. You are trying to set mypres without ever declaring it.

My other guess is that there is no "ActivePresentation" but that might be way out in left field. The error details might tell anyone if that is a viable guess or not.

Also turn on "Require Variable Declaration" in the vb editor options. Note that this does not add Option Explicit to existing code modules; you'll have to add it manually if you want it there. Failure to use Option Explicit is just asking for trouble, and is not something an 'expert' should ever do.

Please post code, properly indented, within code tags (vba button on posting toolbar).

 

[onthegreen03]

Indicating which line causes an error is great. Not providing the error number or message - not so much. IMO, most of the time the best you can expect to get is a shot in the dark like this one: Declare your variables. You are trying to set mypres without ever declaring it.

My other guess is that there is no "ActivePresentation" but that might be way out in left field. The error details might tell anyone if that is a viable guess or not.

Also turn on "Require Variable Declaration" in the vb editor options. Note that this does not add Option Explicit to existing code modules; you'll have to add it manually if you want it there. Failure to use Option Explicit is just asking for trouble, and is not something an 'expert' should ever do.

Please post code, properly indented, within code tags (vba button on posting toolbar).

Thanks for the reply. Sorry about mis-posting the code. Did I get it right this time?

Sub RunAllMacros()
'
Procedure1
Procedure2
MsgBox "Success!", 64
End Sub
Sub Procedure1()
'
Set objppt = CreateObject("PowerPoint.Application")
objppt.Visible = True
objppt.Presentations.Open "C:\USERS\michael.green\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

 

[Worf]

Post #90 of this thread shows the variables properly declared.

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

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...

www.mrexcel.com

 

[Micron]

That's much easier to read, but still nothing declared...

 

[Micron]

I think when you cross post, even though it's in the same forum, you're supposed to advise and post a link?

Adding my 2 cents re the code there: might be worth noting that this

shp As Object, sar, i%, rad, wa, ha, la, ta, tsl%, bl%

is OK if you want the last 9 variables to be variants, which I believe is the case there. However, I'd never use special characters in any object name and prefer to declare as a variant rather than default to it. Kinda avoids any ambiguity I think. If there is a requirement to use % in a variable name could someone let me know please?

 

[onthegreen03]

Thanks for pointing out my problem @Worf , I was not copying the entire code from the old file (missing the declarations at the top). When I add that back into the code it starts to copy the copy the tabs but then stops after the third slide and I get this error.

Macro stops at: sl.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile

Dim thisDate As Date
Dim 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\michael.green\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

 

[onthegreen03]

I think when you cross post, even though it's in the same forum, you're supposed to advise and post a link?

Adding my 2 cents re the code there: might be worth noting that this

is OK if you want the last 9 variables to be variants, which I believe is the case there. However, I'd never use special characters in any object name and prefer to declare as a variant rather than default to it. Kinda avoids any ambiguity I think. If there is a requirement to use % in a variable name could someone let me know please?

Thanks for helping out Micron. I was not trying to break any posting rules, not even sure if I did anything wrong. Apologize for the confusion.

 

[Micron]

Apologies are better than what I sometimes get for pointing that out. Elsewhere, I post a link about the why's and wherefor's about cross posting, but not here as it got me into trouble before. So I leave the teaching (or whatever) to the moderators. Too bad, because I think it's quite educational on the subject, and in a very polite way.

You are obviously in good hands here, so I probably should let Worf guide you from here. BTW, I like your handle. I think it means "on the green in 3 strokes" but that's only a good thing if its a par 5?

 

[Worf]

Micron

The following two statements are the same:

Dim i%

Dim i as Integer