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

O

onthegreen03

Board Regular
Joined
Jun 30, 2016
Messages
168
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:

Excel Facts

Repeat Last Command
Pressing F4 adds dollar signs when editing a formula. When not editing, F4 repeats last command.
Sort by date Sort by votes
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).
 
Upvote 0
Micron said:
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).
Click to expand...
Thanks for the reply. Sorry about mis-posting the code. Did I get it right this time?

VBA Code: 
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
 
Upvote 0
Post #90 of this thread shows the variables properly declared.

www.mrexcel.com

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 www.mrexcel.com
 
Upvote 0
That's much easier to read, but still nothing declared...
 
Upvote 0
I think when you cross post, even though it's in the same forum, you're supposed to advise and post a link? :unsure:

Adding my 2 cents re the code there: might be worth noting that this
Worf said:
shp As Object, sar, i%, rad, wa, ha, la, ta, tsl%, bl%
Click to expand...
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?
 
Upvote 0
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.

1647284309810.png


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

VBA Code: 
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
 

Attachments

  • 1647284038569.png
    1647284038569.png
    7.1 KB · Views: 16
Upvote 0
Micron said:
I think when you cross post, even though it's in the same forum, you're supposed to advise and post a link? :unsure:

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?
Click to expand...
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.
 
Upvote 0
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? :biggrin:
 
Upvote 0
Micron

The following two statements are the same:

VBA Code: 
Dim i%

Dim i as Integer
 
Upvote 0
You must log in or register to reply here.

Forum statistics

Threads
1,223,903
Messages
6,175,284
Members
452,630
Latest member
OdubiYouth

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