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



## onthegreen03 (Jun 30, 2016)

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


----------



## Colorations (Jun 30, 2016)

Your myPresentation variable isn't set to anything.  I'm not familiar with powerpoint vba but maybe replace 

```
Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly
```
with

```
Set mySlide = Application.ActivePresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly
```


----------



## onthegreen03 (Jun 30, 2016)

Thanks for the reply Colorations.   I tried your suggestion and it didn't work.   Still stopping at that line of code.   If you have any other recommendations I would love to hear them.


----------



## Colorations (Jun 30, 2016)

It seems none of your variables have been instantiated so that's probably why this error and errors further down occur


----------



## onthegreen03 (Jun 30, 2016)

Yeah.  If there are any VBA freaks of nature out there willing to re-write the Procedure2 code so that it works with Procedure1 I would be very grateful.  Seems like I am close but I don't have the VBA chops to link the two procedures together.


----------



## Worf (Jun 30, 2016)

Like this:


```
' Excel module
Dim objppt As PowerPoint.Application


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


Sub Procedure1()
Set objppt = CreateObject("PowerPoint.Application")
objppt.Visible = True
objppt.Presentations.Open "C:\Users\Eddie\Documents\PowerPoint\dt.potx"
End Sub


Sub Procedure2()
Dim rng As Range, mypres As PowerPoint.Presentation, mySlide As Object, myShape As Object
'Copy Range from Excel
Set rng = ThisWorkbook.ActiveSheet.[A1:C12]
Set mypres = objppt.ActivePresentation
Set mySlide = mypres.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
objppt.Visible = 1
objppt.Activate
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
```


----------



## onthegreen03 (Jun 30, 2016)

Thanks.  I will try this and let you know if it works.  Appreciate the help!


----------



## onthegreen03 (Jul 1, 2016)

THANK YOU Worf!  You fixed it and it works all the way through.   I realy appreciate the assistance on that one!


----------



## Worf (Jul 1, 2016)

You are welcome!


----------



## onthegreen03 (Jul 19, 2016)

Hey Worf - I was wondering if you could help me one more time with this code?   Let me know if you have some time to hear my plea.   Thanks!


----------



## onthegreen03 (Jun 30, 2016)

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 (Jul 19, 2016)

Sure. I'm waiting for your post...


----------



## onthegreen03 (Jul 20, 2016)

Thanks Worf!

Okay, the code below works great for one range pasting into one slide in PP.   I now want to expand it so that it copies one range from multiple tabs within the same Excel worksheet and pastes them into separate slides in the same PP deck.   Can you help me build out the code so that it takes a range from 3 sheets (assume the sheet names as Sheet1, Sheet2, and Sheet3) and pastes them into the same PP deck?   When done the PP deck will have 3 slides .... sometimes the code adds an extra slide which I prefer not to have.  Assume the same range in all 3 sheets for now and the same sizing (if that is something you have to code separately).   I thought once I have the basic coding down for 3 sheets I can easily add more sheets as needed.

I really appreciate your help on this "project".  Believe it or not I've learned a lot and actually enjoy VBA .... wish I learned it earlier in life.

I will wait for your reply.

Thanks again!

' Excel module
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 "M:\Forecasting\Models\Data Summary\E2P\Blank.potx"
End Sub

Sub Procedure2()

Dim rng As Range, mypres As PowerPoint.Presentation, mySlide As Object, myShape As Object

Set rng = ThisWorkbook.ActiveSheet.[B2:Q20]
Set mypres = objppt.ActivePresentation
Set mySlide = objppt.ActiveWindow.View.Slide

'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 = 8
myShape.Top = 100
myShape.Width = 700
myShape.Height = 400

'Make PowerPoint Visible and Active
objppt.Visible = 1
objppt.Activate

'Clear The Clipboard
Application.CutCopyMode = False
End Sub


----------



## Worf (Jul 21, 2016)

Please test this:


```
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 "d:\pub\template.potx"        ' your path here
End Sub

Sub Procedure2()
Dim rng As Range, mypres As PowerPoint.Presentation, mySlide As Object, myShape As Object, sar, i%
sar = Array("Sheet1", "Sheet2", "Sheet3")
Set mypres = objppt.ActivePresentation
Set mySlide = objppt.ActiveWindow.View.Slide
For i = LBound(sar) To UBound(sar)
    Set rng = ThisWorkbook.Sheets(sar(i)).[b2:q20]      ' ranges can be different if needed
    rng.Copy
    mySlide.Shapes.PasteSpecial DataType:=2             '2 = ppPasteEnhancedMetafile
    Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
    myShape.Left = 8
    myShape.Top = 80
    myShape.Width = 300                                 ' sizes can be different if needed
    myShape.Height = 350
    Set mySlide = mypres.Slides.Add(mypres.Slides.Count + 1, 11)
Next
If mypres.Slides.Count > 3 Then mypres.Slides(mypres.Slides.Count).Delete
objppt.Visible = 1
objppt.Activate
Application.CutCopyMode = False     ' clear clipboard
mypres.SaveAs "d:\pub\finaldeck.pptx"
End Sub
```


----------



## onthegreen03 (Jul 21, 2016)

Hi Worf -  The macro ran as expected but for the 2nd and 3rd slide it is not resizing the picture to fit the slide.   I'm assuming I can resize each picture as needed but where/how?   Do you mind if I asked you to select 3 different ranges and 3 different sizes so I can see how you write the code?   You don't know how much I appreciate the help on this!!!  If you get sick of helping let me know and I'll stop bothering you.  Also, if you want to take this off line I can send you my email if its easier.   Thanks again!   This is genius.


----------



## Worf (Jul 23, 2016)

> If you get sick of helping let me know



This is fun for me... 



> if you want to take this off line



Forum rule #4 forbids us to do that, see the link on my signature.


```
' Excel module
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:\users\public\template.potx"        ' your path here
End Sub


Sub Procedure2()
Dim rng As Range, mypres As PowerPoint.Presentation, mySlide As Object, _
myShape As Object, sar, i%, rad, wa, ha
sar = Array("Sheet1", "Sheet2", "Sheet3")
rad = Array("b2:q20", "d4:p18", "e6:n12")               ' ranges
wa = Array(0.9, 0.8, 0.75)                              ' percentages of slide width and height
ha = Array(0.85, 0.7, 0.65)
Set mypres = objppt.ActivePresentation
Set mySlide = objppt.ActiveWindow.View.Slide
For i = LBound(sar) To UBound(sar)
    Set rng = ThisWorkbook.Sheets(sar(i)).Range(rad(i))
    rng.Copy
    mySlide.Shapes.PasteSpecial DataType:=2             '2 = ppPasteEnhancedMetafile
    Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
    myShape.Left = 8
    myShape.Top = 80
    myShape.Width = wa(i) * mypres.PageSetup.SlideWidth ' set picture size
    myShape.Height = ha(i) * mypres.PageSetup.SlideHeight
    Set mySlide = mypres.Slides.Add(mypres.Slides.Count + 1, 11)
Next
If mypres.Slides.Count > 3 Then mypres.Slides(mypres.Slides.Count).Delete
objppt.Visible = 1
objppt.Activate
Application.CutCopyMode = False                         ' clear clipboard
mypres.SaveAs "c:\users\public\finaldeck.pptx"
End Sub
```


----------



## onthegreen03 (Jul 25, 2016)

Hi Worf - I pasted in the new code and the different ranges are working and I now understand how to add sheets with different ranges (thanks!!!).   Still having a problem with sizing the ranges into the slides.   For all 3 ranges the width is too long ... the picture hangs off the right side of the slide by a lot.   I tried to change the percentages under the "wa" line of code (lowered to 40%) but it didn't seem to change the width at all.   Maybe I am not changing the right code?   Do you mind taking another look at it?   Do you see the same thing when you run it on your end?   As always I appreciate your willingness to help.   And to avoid breaking board rules I will keep replying through this thread ... I am a relative newbie to the site.  After we (you) fix this I have one more very small favor to ask ... you'll be able to fix it in about 2 mins.    I'll wait to hear from you.   Thanks again.


----------



## Worf (Jul 25, 2016)

Does this fix it?


```
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.potx"        ' your path here
End Sub


Sub Procedure2()
Dim rng As Range, mypres As PowerPoint.Presentation, mySlide As Object, _
myShape As Object, sar, i%, rad, wa, ha
sar = Array("Sheet1", "Sheet2", "Sheet3")
rad = Array("b2:q20", "d4:p18", "e6:n12")               ' ranges
wa = Array(0.25, 0.3, 0.45)                              ' percentages of slide width and height
ha = Array(0.85, 0.7, 0.65)
Set mypres = objppt.ActivePresentation
Set mySlide = objppt.ActiveWindow.View.Slide
For i = LBound(sar) To UBound(sar)
    Set rng = ThisWorkbook.Sheets(sar(i)).Range(rad(i))
    rng.Copy
    mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
    Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
[COLOR=#ff8c00]    myShape.LockAspectRatio = 0[/COLOR]
    myShape.Left = 8
    myShape.Top = 80
    myShape.Width = wa(i) * mypres.PageSetup.SlideWidth ' set picture size
    myShape.Height = ha(i) * mypres.PageSetup.SlideHeight
    Set mySlide = mypres.Slides.Add(mypres.Slides.Count + 1, 11)
Next
'If mypres.Slides.Count > 3 Then mypres.Slides(mypres.Slides.Count).Delete
objppt.Visible = 1
objppt.Activate
Application.CutCopyMode = False                         ' clear clipboard
mypres.SaveAs "c:\pub\finaldeck.pptx"
End Sub
```


----------



## onthegreen03 (Jul 26, 2016)

Hi Worf - I had to change the wa settings but it is working and resizing as needed.   The last request with this code .... can you update the coding so it does not add an empty slide at the end?   Currently it leaves an empty (blank) slide.  I love that you added the save file feature .... very nice!    After this I have one more favor to ask regarding another VBA code I've been tinkering around with.   Thanks!!!!


----------



## Worf (Jul 26, 2016)

This one should produce a three slide presentation:


```
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.potx"        ' your path here
End Sub


Sub Procedure2()
Dim rng As Range, mypres As PowerPoint.Presentation, mySlide As Object, _
myShape As Object, sar, i%, rad, wa, ha
sar = Array("Sheet1", "Sheet2", "Sheet3")
rad = Array("b2:q20", "c4:p18", "e6:n12")               ' ranges
wa = Array(0.25, 0.3, 0.45)                              ' percentages of slide width and height
ha = Array(0.85, 0.7, 0.65)
Set mypres = objppt.ActivePresentation
Do While mypres.Slides.Count > 1
    mypres.Slides(mypres.Slides.Count).Delete
Loop
Set mySlide = objppt.ActiveWindow.View.Slide
For i = LBound(sar) To UBound(sar)
    Set rng = ThisWorkbook.Sheets(sar(i)).Range(rad(i))
    rng.Copy
    mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
    Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
    myShape.LockAspectRatio = 0
    myShape.Left = 8
    myShape.Top = 80
    myShape.Width = wa(i) * mypres.PageSetup.SlideWidth ' set picture size
    myShape.Height = ha(i) * mypres.PageSetup.SlideHeight
    Set mySlide = mypres.Slides.Add(mypres.Slides.Count + 1, 11)
Next
If mypres.Slides.Count > 3 Then mypres.Slides(mypres.Slides.Count).Delete
objppt.Visible = 1
objppt.Activate
Application.CutCopyMode = False                         ' clear clipboard
mypres.SaveAs "c:\pub\finaldeck.pptx"
End Sub
```


----------



## onthegreen03 (Jul 27, 2016)

Thanks Worf!   It worked like a charm and I really appreciate the help with that code.    Last request (I hope).   Below is another code I've pieced together from different sources to copy/paste charts from Excel to PP.   The code works except that it leaves the first slide blank and adds slides from there.   Like the last request I would like to have it start pasting from the active slide upon opening the deck and adding from there so that no blank slides exist after the code runs.    As always thanks for the help!!!

Sub CreatePowerPoint()

 'Add a reference to the Microsoft PowerPoint Library by:
    '1. Go to Tools in the VBA menu
    '2. Click on Reference
    '3. Scroll down to Microsoft PowerPoint X.0 Object Library, check the box, and press Okay

    'First we declare the variables we will be using
        Dim newPowerPoint As PowerPoint.Application
        Dim activeSlide As PowerPoint.Slide
        Dim cht As Excel.ChartObject

     'Look for existing instance
        On Error Resume Next
        Set newPowerPoint = CreateObject("PowerPoint.Application")
       newPowerPoint.Visible = True
       newPowerPoint.Presentations.Open "M:\Forecasting\Models\2016\Data Summary\E2P\Blank.potx"
        On Error GoTo 0

    'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
        For Each cht In ActiveSheet.ChartObjects

        'Add a new slide where we will paste the chart
            newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText
            newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
            Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)

        'Copy the chart and paste it into the PowerPoint as a Metafile Picture
            cht.Select
            ActiveChart.ChartArea.Copy
            activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select

        'Set the title of the slide the same as the title of the chart
            activeSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text

        'Adjust the positioning of the Chart on Powerpoint Slide
            newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 15
            newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 125

            activeSlide.Shapes(2).Width = 200
            activeSlide.Shapes(2).Left = 505

        'If the chart is the "Revlimid" consumption chart, then enter the appropriate comments
            If InStr(activeSlide.Shapes(1).TextFrame.TextRange.Text, "Revlimid") Then
                activeSlide.Shapes(2).TextFrame.TextRange.Text = Range("J7").Value & vbNewLine
                activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J8").Value & vbNewLine)
                activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J9").Value & vbNewLine)
                activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J10").Value & vbNewLine)
        'Else if the chart is the "Pomalyst" consumption chart, then enter the appropriate comments
            ElseIf InStr(activeSlide.Shapes(1).TextFrame.TextRange.Text, "Pomalyst") Then
                activeSlide.Shapes(2).TextFrame.TextRange.Text = Range("J27").Value & vbNewLine
                activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J28").Value & vbNewLine)
                activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J29").Value & vbNewLine)
                activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J30").Value & vbNewLine)
            End If

        'Now let's change the font size of the callouts box
            activeSlide.Shapes(2).TextFrame.TextRange.Font.Size = 16

        Next

    AppActivate ("Microsoft PowerPoint")
    Set activeSlide = Nothing
    Set newPowerPoint = Nothing

End Sub


----------



## onthegreen03 (Jun 30, 2016)

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 (Jul 28, 2016)

Please test this:


```
Sub CreatePowerPoint()
'Add a reference to the Microsoft PowerPoint Library by:
'1. Go to Tools in the VBE menu
'2. Click on Reference
'3. Scroll down to Microsoft PowerPoint X.0 Object Library, check the box, and press Okay
'First we declare the variables we will be using
Dim newPowerPoint As PowerPoint.Application, activeSlide As PowerPoint.Slide
Dim cht As Excel.ChartObject, pres As Presentation
'Look for existing instance
On Error Resume Next
Set newPowerPoint = CreateObject("PowerPoint.Application")
newPowerPoint.Visible = True
newPowerPoint.Presentations.Open "c:\pub\template2.potx"
On Error GoTo 0
Set pres = newPowerPoint.ActivePresentation
Do While pres.Slides.Count > 1
    pres.Slides(pres.Slides.Count).Delete
Loop
'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
For Each cht In ActiveSheet.ChartObjects
    'Add a new slide where we will paste the chart
    pres.Slides.Add pres.Slides.Count + 1, ppLayoutText
    newPowerPoint.ActiveWindow.View.GotoSlide pres.Slides.Count
    Set activeSlide = pres.Slides(pres.Slides.Count)
    'Copy the chart and paste it into the PowerPoint as a Metafile Picture
    cht.Select
    ActiveChart.ChartArea.Copy
    activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select
    'Set the title of the slide the same as the title of the chart
    activeSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text
    'Adjust the positioning of the Chart on Powerpoint Slide
    newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 15
    newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 125
    activeSlide.Shapes(2).Width = 200
    activeSlide.Shapes(2).Left = 505
    'If the chart is the "Revlimid" consumption chart, then enter the appropriate comments
    If InStr(activeSlide.Shapes(1).TextFrame.TextRange.Text, "Revlimid") Then
        activeSlide.Shapes(2).TextFrame.TextRange.Text = Range("J7").Value & vbNewLine
        activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J8").Value & vbNewLine)
        activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J9").Value & vbNewLine)
        activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J10").Value & vbNewLine)
    'Else if the chart is the "Pomalyst" consumption chart, then enter the appropriate comments
    ElseIf InStr(activeSlide.Shapes(1).TextFrame.TextRange.Text, "Pomalyst") Then
        activeSlide.Shapes(2).TextFrame.TextRange.Text = Range("J27").Value & vbNewLine
        activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J28").Value & vbNewLine)
        activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J29").Value & vbNewLine)
        activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J30").Value & vbNewLine)
    End If
    activeSlide.Shapes(2).TextFrame.TextRange.Font.Size = 16    ' callout box
Next
pres.Slides(1).Delete
AppActivate ("Microsoft PowerPoint")
Set activeSlide = Nothing: Set newPowerPoint = Nothing
pres.SaveAs "c:\pub\finaldeck.pptx"
MsgBox "End of code!", vbInformation
End Sub
```


----------



## onthegreen03 (Aug 1, 2016)

Hi Worf - Works like a charm!   I really want to thank you again for all of your help on these various VBA codes.   If you don't mind the challenge (both big and small) I will reply to this post if I run into a more problems.   There are a few more things I am working on that may require some professional intervention!    Thanks again!!!


----------



## Worf (Aug 1, 2016)

You are welcome! 



> If you don't mind the challenge



I am always up for a challenge…


----------



## Worf (Aug 1, 2016)

.


----------



## onthegreen03 (Aug 11, 2016)

Hi Worf - Question about an VBA error I get when I try to run that copy/paste from Excel to PP (single range).   I copied the code from one Excel file to another one and changed the range I am trying to copy.  When I run the macro I get an error message (Reads "Compile Error: User-Defined type not defined".)  The code stops at Procedure 2 and the code that reads "mypres As PowerPoint.Presentation" is highlighted.   I tried the code in the original Excel file and it runs all the way through with no problems, but when I copy the code to another file and try to run the code it does not work.   Can you please disagnois and help me find the error in my ways?   Code below in case you need it.

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

Sub Procedure1()
Set objppt = CreateObject("PowerPoint.Application")
objppt.Visible = True
 objppt.Presentations.Open "M:\Forecasting\Models\2016\Data Summary\E2P\Blank.potx"
End Sub

Sub Procedure2()

Dim rng As Range, mypres As PowerPoint.Presentation, mySlide As Object, myShape As Object

Set rng = ThisWorkbook.ActiveSheet.[B1:N30]
Set mypres = objppt.ActivePresentation
Set mySlide = objppt.ActiveWindow.View.Slide

'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 = 8
myShape.Top = 100
myShape.Width = 700
myShape.Height = 400


----------



## Worf (Aug 12, 2016)

Hi

On the new file, set a reference at VBE>Tools>References>Microsoft PowerPoint Object Library.


----------



## onthegreen03 (Aug 16, 2016)

Hi Worf - 

I did as you instucted and tried running the code again in that new Excel template.  When I run the code now it opens up an instance of PP (all good so far) but it stops at the line "Set mypres = objppt,.ActivePresentation" and that line is highlighted in yellow.  If it wasn't clear from my last post I am trying to make these marcos "portable" so I can simply copy them from one Excel file to another and change the range that I want to copy.   I'd like to make the multiple range macro portable as well ... once we solve this issue I will likely need to apply the same fix to the other macro you worked on for me that copies multiple ranges.

Let me know what you think ... you said you like challenges!

Thanks!


----------



## Worf (Aug 16, 2016)

Hi

1)    The code below worked for me. What error number and message are you getting?
2)    Concerning portability, we can choose between early and late binding. See this page: Early vs. Late Binding


```
' Excel module
Dim objppt As PowerPoint.Application


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


Sub Procedure1()
Set objppt = CreateObject("PowerPoint.Application")
objppt.Visible = True
objppt.Presentations.Open "c:\pub\template2.potx"
End Sub


Sub Procedure2()
Dim rng As Range, mypres As PowerPoint.Presentation, mySlide As Object, myShape As Object
Set rng = ThisWorkbook.ActiveSheet.[B1:N30]
Set mypres = objppt.ActivePresentation
Set mySlide = objppt.ActiveWindow.View.Slide
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 = 8
myShape.Top = 100
myShape.Width = 700
myShape.Height = 400
End Sub
```


----------



## onthegreen03 (Aug 25, 2016)

Hi Worf - I'm glad I logged in .... I never received email notification that you responded to my last post.  I thought you gave up on me!   Let me try pasting in the code you sent that worked for you and I'll let you know what error message I get.   Hopefully it will work.   It's weird.   The code runs beautifully when I run it in the original file that you helped me with back in July. But when I try to copy the code to a new Excel template and run the code it does not work.   Let me try again now and I'll get back to you today or tomorrow.   Thanks again for sticking around with this.  Would love to discuss the early and late binding with you .... maybe you can tell me which one would work better based on how I plan to use the coding.


----------



## onthegreen03 (Aug 25, 2016)

Hi Worf - It worked!  I'm not sure what I was doing wrong the first couple of times I tried it but it appears to be fine now.  I opened a new Excel spreadsheet, set the reference to PP, and pasted in the code.   It ran all the way through.   Can you explain early vs. late binding?  Upon reading the link you sent it appears the code I have is using early binding.   If I understood the article correctly if I used late binding I would not have to worry about setting the reference to PP.   Is that the key difference?


----------



## onthegreen03 (Jun 30, 2016)

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 (Aug 27, 2016)

> Is that the key difference?



Yes. This page gives a good explanation: VBA references and early binding vs late binding | Excel Matters


----------



## onthegreen03 (Sep 6, 2016)

Thanks again Worf for all of your help.   I hope you don't mind that I drop you a post every now and again as I continue to venture into unchartered (for me) VBA territory.   Be well.


----------



## onthegreen03 (Sep 15, 2016)

Hi Worf - Me again from sunny New Jersey, USA.   I'm still having a problem with that Excel to PP code.   When I run the code it opens PP but stops at the following line in *red* below.

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

Sub Procedure1()
Set objppt = CreateObject("PowerPoint.Application")
objppt.Visible = True
objppt.Presentations.Open "M:\Forecasting\Models\2016\Data Summary\E2P\Blank.potx"
End Sub

Sub Procedure2()
Dim rng As Range, mypres As PowerPoint.Presentation, mySlide As Object, myShape As Object
Set rng = ThisWorkbook.ActiveSheet.[B1:N30]
*Set mypres = objppt.ActivePresentation*
Set mySlide = objppt.ActiveWindow.View.Slide
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 = 8
myShape.Top = 100
myShape.Width = 700
myShape.Height = 400
End Sub

Some issue I had before.  It works when I run it in the original file but when I copy the code and try running it in another file it does not work.   I'd really like to get this thing working consistently.   Any help or advice you can give me would be appreciated.   Thanks in advance!


----------



## Worf (Sep 16, 2016)

Try this new version:


```
' Excel module
Sub Copy6in2016()
Dim rng As Range, mypres As PowerPoint.Presentation, mySlide As Object, _
myShape As Object, objppt As PowerPoint.Application
Set objppt = CreateObject("PowerPoint.Application")
objppt.Visible = True
objppt.Presentations.Open "c:\pub\template2.potx"       ' your path here
Set rng = ThisWorkbook.ActiveSheet.[B1:N30]
Set mypres = objppt.ActivePresentation
Set mySlide = objppt.ActiveWindow.View.Slide
rng.Copy
mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
myShape.Left = 8        ' set position
myShape.Top = 100
myShape.Width = 700
myShape.Height = 400
MsgBox "Success!", 64
End Sub
```


----------



## onthegreen03 (Sep 21, 2016)

Worked like a charm!   Awesome stuff Worf.    I may have another challenge for you regarding sizing my Excel objects in PP once I paste them as pics.   Let me troubleshoot and I'll send you another post in a day or two.   As always thanks for the help!


----------



## onthegreen03 (Sep 28, 2016)

Hi Worf - I have a question on a different topic.   I created a waterfall chart in Excel and one of the values is a negative number.   But when I add data labels the number in the label does not show the negative sign so it appears as a positive number even though the corresponding bar is going down.  I've tried going into formatting to change the number format to Currency so I can then select the negative value there but it won't let me select it as an option.  How can I can format the data label to show the negative number when in fact the number is negative?  Let me know if you need more information or would like to see the actual file.   Thanks as always.


----------



## Worf (Sep 28, 2016)

Hi

·         What Excel version are you using? Did you create the chart with Excel built-in capabilities or using an add-in? Microsoft only with Office 2016 introduced waterfall charts.
·         Working with the actual file is always better, if you can provide a link to it.
·         When the topic at hand is different from the thread originator, it is preferable to start a new thread.
·         Let us see if this can be sorted out without code…


----------



## onthegreen03 (Sep 29, 2016)

Hi Worf -

I am using Excel 2016 but the waterfall was manually built.  You know what, let's drop this issue and stay with the original thread as you suggest.   I didn't mean to deviate ... it was just frustrating me that I could not figure it out.   I will keep trying ... a workaround is inserting a text box and linking it to the negative number rather than using the data label.

Okay, you said you like challenges so here is one.  I am almost done with the Excel to PP code.   I have it built where I am copying multiple ranges from different tabs and pasting into PP and it works beautifully.   I have 2 hurdles I'd like to clear:

1.  Do you know how to add titles to each of the generated slides?  What I'd like is that for every slide added I can add a unique slide title to each.   Ideally each slide would have a title and subtitle.   See the link below that I found on the Microsoft site.  It seems there is a way to add slide titles but the code it way beyond my capabilities.

https://support.microsoft.com/en-us/kb/162612

2.  In the current code there is the ability to move the pictures left and down from the top using the myshape.left and myshape.top lines of code.  Is it possible to change these setting to an array so I can adjust each slide individually (similar to how I can adjust the width and height of the picture)?

Current code is 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 "M:\Forecasting\Models\2016\Data Summary\E2P\Blank.potx"        ' your path here
End Sub

Sub Procedure2()
Dim rng As Range, mypres As PowerPoint.Presentation, mySlide As Object, _
myShape As Object, sar, i%, rad, wa, ha
sar = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5", "Sheet6")
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 mySlide = objppt.ActiveWindow.View.Slide
For i = LBound(sar) To UBound(sar)
    Set rng = ThisWorkbook.Sheets(sar(i)).Range(rad(i))
    rng.Copy
    mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
    Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
    myShape.LockAspectRatio = 0
    myShape.Left = 40
    myShape.Top = 80
    myShape.Width = wa(i) * mypres.PageSetup.SlideWidth ' set picture size
    myShape.Height = ha(i) * mypres.PageSetup.SlideHeight
    Set mySlide = mypres.Slides.Add(mypres.Slides.Count + 1, 11)
Next
If mypres.Slides.Count > 3 Then mypres.Slides(mypres.Slides.Count).Delete
objppt.Visible = 1
objppt.Activate
Application.CutCopyMode = False                         ' clear clipboard
mypres.SaveAs "c:\pub\finaldeck.pptx"
End Sub

Thanks!!


----------



## Worf (Sep 30, 2016)

I don’t like unanswered topics, so:

-The picture below shows two charts, the one above is a true waterfall, and both displayed the negative sign automatically.
-Another way to insert information into data labels is the value from cells option, also shown.
-I’ll be back later with the PowerPoint stuff.


----------



## onthegreen03 (Sep 30, 2016)

Next time you are in the Stares I owe you a drink!   I'll wait to hear from you on the PP questions.   That automation is cool stuff.   As always give me the word when you get sick of me.


----------



## onthegreen03 (Jun 30, 2016)

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 (Sep 30, 2016)

This version includes titles, subtitles and custom image positioning:


```
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:\users\public\template.potx" ' your path here
End Sub

Sub Procedure2()
Dim rng As Range, mypres As PowerPoint.Presentation, mySlide As Object, _
myShape As Object, sar, i%, rad, wa, ha, tit, subtit, la, ta
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 mySlide = objppt.ActiveWindow.View.Slide
For i = LBound(sar) To UBound(sar)
    mySlide.Shapes(1).TextFrame.TextRange.Text = tit(i)
    mySlide.Shapes(2).TextFrame.TextRange.Text = subtit(i)
    Set rng = ThisWorkbook.Sheets(sar(i)).Range(rad(i))
    rng.Copy
    mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
    Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
    myShape.LockAspectRatio = 0
    myShape.Left = la(i)
    myShape.Top = ta(i)
    myShape.Width = wa(i) * mypres.PageSetup.SlideWidth                     ' set picture size
    myShape.Height = ha(i) * mypres.PageSetup.SlideHeight
    Set mySlide = mypres.Slides.Add(mypres.Slides.Count + 1, ppLayoutTitle) ' title and subtitle
Next
If mypres.Slides.Count > 3 Then mypres.Slides(mypres.Slides.Count).Delete
objppt.Visible = 1
objppt.Activate
Application.CutCopyMode = False ' clear clipboard
mypres.SaveAs "c:\users\public\finaldeck.pptx"
End Sub
```


----------



## onthegreen03 (Oct 1, 2016)

Very cool worf.   Will try this on Monday.   Can't wait to see how it works.    Thanks!!!!


----------



## onthegreen03 (Oct 3, 2016)

Hey Worf - I tried the new PP code and something weird is happening.   It starts to run and opens up that blank PP template and for the first slide everything looks okay.  But starting with the second slide it is pasting the Excel ranges into one of our standard company cover slides.  I'm not sure where it is grabbing that from but slides 2-6 are all pasted on a cover slide.  Normally the code just copied that first (blank) slide and used it all the way through.  The ranges appear to be copying correctly and sizing looks good.  Also, on the first slide (that appears on the correct slide format) I do see the main title box but not the subtitle.   Maybe we can address that issue after you first try and figure out why this new code is bringing in a cover slide.   I can send you screen shots if that is helpful.   Thanks!


----------



## Worf (Oct 3, 2016)

It is probably coming from the layout gallery. Please use the code below to check that and tell me which of your options I should pick.









```
' PowerPoint module
Sub XRay()
Dim i%, sm
Set sm = ActivePresentation.Designs(1).SlideMaster
For i = 1 To sm.CustomLayouts.Count
    MsgBox sm.CustomLayouts(i).Name, 64, "#" & i
Next
End Sub
```


----------



## onthegreen03 (Oct 4, 2016)

Sorry you lost me.   What do you need me to do with that code?   Run it in Excel?  PP?   What options will I be sending you?  Can you send me more detailed steps so I can execute it correctly.


----------



## onthegreen03 (Oct 4, 2016)

Hi Worf - 

I got very lucky and somehow fixed the problem with the cover slide being added.   I went back to the old code (before you added array titles, etc.) and compared it to the new code.  I changed the line below from the new code based on the old code:

Set mySlide = mypres.Slides.Add(mypres.Slides.Count + 1, ppLayoutTitle)

Changed to

Set mySlide = mypres.Slides.Add(mypres.Slides.Count + 1, 11)

By changing pplayoutTitle to 11 it appears to fix the problem (I have no idea why).   But now the Excel ranges are correctly pasting to blank PP slides.   Sizing and positioning is working.   All good there.

Next problem.  I noticed that the Title is being added to each slide (Title1, Title2, etc) but not the subtitle.   Any idea how to fix that?   Ideally I would like the Title and right below the subtitle.  Also, if there is a way to set the font size so the subtitle is a bit smaller that would be cool.  If not no big deal.

Thanks!


----------



## Worf (Oct 4, 2016)

That’s because ppLayoutTitle=1, includes title and subtitle; ppLayoutTitleOnly=11, as the constant name implies, only title.
I will write code that inserts the subtitle manually, with custom font and position.
One thing that will help me is knowing your slide structure; please copy the code below to the current presentation with the subtitle issue, run it and report back the results; you should get names like title, placeholder, footer, header…



```
' this goes at a PowerPoint module
Sub CountShapes()
Dim i%, slnumber%, sl As Slide
slnumber = 2                                    ' choose a slide number
Set sl = ActivePresentation.Slides(slnumber)
For i = 1 To sl.Shapes.Count
    MsgBox sl.Shapes(i).Name                    ' I need these names...
Next
End Sub
```


----------



## onthegreen03 (Oct 5, 2016)

Okay.  I ran the code and here is what returned:

Title 7    <hit Ok="">
Slide Number Placeholder 3   <hit Ok="">
Slide Number Placeholder 3   <hit Ok="">

That was it.   Nothing about header or footer, and yes that slide number message did repeat.  Not sure this matters but in that .potx file I have only 1 slide showing but eventually I would like to add a cover slide.  So when the macro runs it pastes the Excel ranges starting with slide 2.  That is a question for another day.

Let me know if you need anything else as it relates to this current issue.</hit></hit></hit>


----------



## Worf (Oct 5, 2016)

I’ve been thinking and manually adding subtitles is not the best solution. Instead, we can initially add a title slide, which will have the title and subtitle placeholders, and later change its layout, after inserting the desired text.

To do that, I need you to run the code at post #44, it’s a PowerPoint macro. It will give me your layout options, which you can see by clicking the layout button as shown at that same post.


----------



## onthegreen03 (Oct 5, 2016)

Ok.  Will run first thing in the AM.


----------



## onthegreen03 (Jun 30, 2016)

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


----------



## onthegreen03 (Oct 6, 2016)

Okay Worf ... here are the results of the code in thread #44.  A number appears at the top of each message box which I've detailed below:

#1 = Title Slide
#2 = 1_Title Slide
#3 = Title and Content
#4 = Two Content
#5 = Comparison
#6 = Title Only
#7 = Blank

Let me know what else you need and thanks for working on this!


----------



## Worf (Oct 6, 2016)

This worked for me:


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

Sub Procedure1()
Set objppt = CreateObject("PowerPoint.Application")
objppt.Visible = True
objppt.Presentations.Open "c:\users\public\template.potx" ' 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
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(2)
For i = LBound(sar) To UBound(sar)
    sl.Shapes(1).TextFrame.TextRange.Text = tit(i)
    sl.Shapes(2).TextFrame.TextRange.Text = subtit(i)
    sl.CustomLayout = mypres.Designs(1).SlideMaster.CustomLayouts(6)        ' title only
    sl.Shapes(1).TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft
    sl.Shapes(1).Top = 50
    sl.Shapes(1).Left = 40
    sl.Shapes(2).Top = sl.Shapes(1).Top + sl.Shapes(1).Height + 5           ' position subtitle
    sl.Shapes(2).Left = 40
    Set rng = ThisWorkbook.Sheets(sar(i)).Range(rad(i))
    rng.Copy
    sl.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
    Set myShape = sl.Shapes(sl.Shapes.Count)
    myShape.LockAspectRatio = 0
    myShape.Left = la(i)
    myShape.Top = ta(i)
    myShape.Width = wa(i) * mypres.PageSetup.SlideWidth                     ' set picture size
    myShape.Height = ha(i) * mypres.PageSetup.SlideHeight
    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
objppt.Visible = 1
objppt.Activate
Application.CutCopyMode = False ' clear clipboard
mypres.SaveAs "c:\users\public\finaldeck.pptx"
End Sub
```


----------



## onthegreen03 (Oct 7, 2016)

Worf - I tried the code and it stops at the code in RED below.  That is the same line that trips me up every once in a while ... not sure why.  I was playing around with the .potx template yesterday and had to resave it, but the code opens up PP with no issue so I don't think that is what is impacting this error.   I feel we are soooooo close!  

Sub RunAllMacros()
Procedure1
Procedure2
MsgBox "Success!", 64
End Sub
Sub Procedure1()
Set objppt = CreateObject("PowerPoint.Application")
objppt.Visible = True
objppt.Presentations.Open "M:\Forecasting\Models\2016\Data Summary\E2P\Blank.potx" ' 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
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(2)
For i = LBound(sar) To UBound(sar)
    sl.Shapes(1).TextFrame.TextRange.Text = tit(i)
    sl.Shapes(2).TextFrame.TextRange.Text = subtit(i)
    sl.CustomLayout = mypres.Designs(1).SlideMaster.CustomLayouts(6)        ' title only
    sl.Shapes(1).TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft
    sl.Shapes(1).Top = 50
    sl.Shapes(1).Left = 40
    sl.Shapes(2).Top = sl.Shapes(1).Top + sl.Shapes(1).Height + 5           ' position subtitle
    sl.Shapes(2).Left = 40
    Set rng = ThisWorkbook.Sheets(sar(i)).Range(rad(i))
    rng.Copy
    sl.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
    Set myShape = sl.Shapes(sl.Shapes.Count)
    myShape.LockAspectRatio = 0
    myShape.Left = la(i)
    myShape.Top = ta(i)
    myShape.Width = wa(i) * mypres.PageSetup.SlideWidth                     ' set picture size
    myShape.Height = ha(i) * mypres.PageSetup.SlideHeight
    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
objppt.Visible = 1
objppt.Activate
Application.CutCopyMode = False ' clear clipboard
mypres.SaveAs "c:\users\public\finaldeck.pptx"
End Sub


----------



## onthegreen03 (Oct 7, 2016)

Worf - Disregard that last post ... I figured out the issue.  I was missing the DIM code in the very beginning ... once I added that the code ran all the way through.  I see the title and subtitle boxes so I'll just need to work on the placement.   My goal today is to work on the code and get the placements and sizes all set.  I'll send you one more post before the end of the day with a list of questions/requests.   For example I'd like the title and subtitle text to be right aligned (not left).    But let me work through the code today so I only send you one list of follow ups as opposed to several posts.   THANKS!!   This looks great and we are sooooo close to getting it done.


----------



## onthegreen03 (Oct 7, 2016)

Okay Worf.  I spent some time working with the code and it works great!   Below is a final list of "things to fix".  I've pasted my current code so you can work off of the latest version ... I changed some of the settings to get the correct placement of the title boxes.

Here it goes:

1.  I see that the title box and subtitle box are 2 separate text boxes.   Is it possible to have the subtitle come in right below the title in the same text box?  If not this is not a deal breaker ... just curious if possible and how hard it would be to change the code at this point.

2.  The subtitle text is black font color .... can you make it white and also italicize it?

3.  The subtitle text has a bullet point .... can you remove the bullet point?

4.  The actual subtitle text box comes in much shorter in length.   Can you make it wider so I can fit a longer string of text?   Or will it fit longer text automatically?   I didn't test that yet.   The title page comes in at the right length.

5.  Can you "Top" align the title text?   I was able to figure out how to right align so I just need the title to be top aligned.   No changes needed to the subtitle here.

6.  Okay here is the "challenging one" .... I know you like challenges.   For some reason on the very first slide the subtitle text box is not being created, but it appears like there is a slide # text box at the top.  (It just has a #1 in the box and does not say "subtitle".)   Slides 2-6 all have the subtitle text box so it's just slide 1 with this problem.    Do you see this same thing?   Maybe it is something in my slide master settings that I need to change?

7.  Last one.  If I were to add a cover slide to that .potx template could you change the code so that the pasting starts with slide #2?   If you want to try that before attempting to troubleshoot and fix issue #6 above let me know.   Perhaps by starting with slide #2 it will automatically fix that problem with the missing subtitle box.    If you want to fix #6 let's leave this for last and perhaps change after all of the other issues are resolved.

Thanks again!

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 "M:\Forecasting\Models\2016\Data Summary\E2P\Blank.potx" ' 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
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(2)
For i = LBound(sar) To UBound(sar)
    sl.Shapes(1).TextFrame.TextRange.Text = tit(i)
    sl.Shapes(2).TextFrame.TextRange.Text = subtit(i)
    sl.CustomLayout = mypres.Designs(1).SlideMaster.CustomLayouts(6)        ' title only
    sl.Shapes(1).TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignRight
    sl.Shapes(1).Top = 7
    sl.Shapes(1).Left = 63
    sl.Shapes(2).Top = sl.Shapes(1).Top + sl.Shapes(1).Height - 30           ' position subtitle
    sl.Shapes(2).Left = 608
    Set rng = ThisWorkbook.Sheets(sar(i)).Range(rad(i))
    rng.Copy
    sl.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
    Set myShape = sl.Shapes(sl.Shapes.Count)
    myShape.LockAspectRatio = 0
    myShape.Left = la(i)
    myShape.Top = ta(i)
    myShape.Width = wa(i) * mypres.PageSetup.SlideWidth                     ' set picture size
    myShape.Height = ha(i) * mypres.PageSetup.SlideHeight
    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
objppt.Visible = 1
objppt.Activate
Application.CutCopyMode = False ' clear clipboard
'mypres.SaveAs "c:\users\public\finaldeck.pptx"
End Sub


----------



## Worf (Oct 8, 2016)

1)    It’s possible, but considering the different formatting required, I would stick with separate boxes, which yield the same end result.
       Items #2 to #5, see 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:\users\public\template.potx" ' 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
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(2)
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(6) ' title only
    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
objppt.Visible = 1
objppt.Activate
Application.CutCopyMode = False ' clear clipboard
'mypres.SaveAs "c:\users\public\finaldeck.pptx"
End Sub
```


----------



## Worf (Oct 8, 2016)

Concerning item#6:

-         I get subtitles on all six slides, but it’s my test template, not yours.
-         Do you still see this behavior with the newest code?
-         Is your template confidential? Could you post a link to it or email me? This would save some time.
-         Please run the code below for layout numbers 1,2,6,7 and report the results; based on post #51 they seem to be the interesting ones.


```
' PowerPoint module
Sub ShapesInLayout()
Dim ln%, sl As Slide, c%, i%
ln = 2                                                          ' layout number
Set sl = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ln)
c = sl.Shapes.Count
For i = 1 To c
    MsgBox sl.Shapes(i).Name, 64, "*" & sl.CustomLayout.Name & "*" & _
    " Shapes ( " & i & " of " & c & ")"
Next
End Sub
```


----------



## Worf (Oct 9, 2016)

At the end of this version, a cover slide is added, as per item #7:


```
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:\accounts\orange.potx" ' 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
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(2)
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(6)    ' title only
    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(1)        ' desired 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 (Oct 11, 2016)

Worf - Sorry for the late response.  I did not receive my usual email indicating a reply to the post.  I actually logged on because I thought maybe you abandoned me!  Glad to see you did not and that you are still working on this issue for me!   Many thanks as usual.   Let me run that code now and I will report back.  What file do you need?   The blank PP template or the one after I run the macro?   I'd be happy to send you either one ... I can just remove any confidential data if needed.  Again, let me know what file(s) you want and I can send them to you.  How would I email you?  In the meantime let me run that code now and I'll report back so you have that.   THANKS!!!


----------



## onthegreen03 (Oct 11, 2016)

Okay I ran the code from 57 ... here you go

Layout 1
"Title Slide" Shapes = Title 1
"Title Slide" Shapes = Subtitle 2

Layout 2
"Title and Text" Shapes = Title 1
"Title and Text" Shapes = Text Placeholder 2
"Title and Text" Shapes = Slide Number Placeholder 3

Layout 6
"Title, Chart and Text" Shapes = Title 1
"Title, Chart and Text" Shapes = Chart Placeholder 2
"Title, Chart and Text" Shapes = Text Placeholder 3
"Title, Chart and Text" Shapes = Slide Number Placeholder 4

Layout 7
"Title and Diagram or Organization Chart" Shapes = Title 1
"Title and Diagram or Organization Chart" Shapes = SmartArt Placeholder 2
"Title and Diagram or Organization Chart" Shapes = Slide Number Placeholder 3

By the way I just ran the new code from 58 and I'm still getting the issue.  The cover slide added (awesome) and slides 3-7 look great.   That first data slide (now slide 2) is still an issue.  The title comes in fine but the subtitle box just has a "2" in it.

Waiting for your reply.


----------



## onthegreen03 (Jun 30, 2016)

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 (Oct 13, 2016)

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 (Oct 14, 2016)

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 (Oct 16, 2016)

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 (Oct 17, 2016)

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:   _Tit_le*2*  (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 (Oct 17, 2016)

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 (Oct 18, 2016)

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 (Oct 19, 2016)

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 (Oct 22, 2016)

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 (Oct 24, 2016)

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 (Oct 25, 2016)

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


----------



## onthegreen03 (Jun 30, 2016)

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


----------



## onthegreen03 (Oct 26, 2016)

Worf - You did it!!!   Awesome job!   The resulting PP looks great now and no extra mag boxes.   I'm not sure how you did it but a BIG thanks.   What I'd like to do before I leave you alone is test it over the next few days with real data (15-20 slides).   I may have some questions about positioning and sizing, formatting, etc.   Once I have that master deck set I'll be off and running.   I'll get in touch with you early next week to let you know where everything stands as it relates to the project.   Thank you!!


----------



## onthegreen03 (Oct 26, 2016)

Worf - Quick question.   Is there a way to link my title and subtitle text to cells in Excel instead of typing them out in VBA?   The problem I am running into is some of my subtitles are really long and contain numbers.  Those numbers change frequently which would require me to constantly update the subtitles in the code.   I was hoping there was a way to link the array titles and subtitles to Excel cells (the same file that I am copying the pictures from).   This way when the macro runs it grabs those updated titles/subtitles and uses them for the corresponding slides.   Does this make sense?   Is it possible?


----------



## Worf (Nov 6, 2016)

Sorry for the delayed answer, I did not see your last post…
This code retrieves the strings from range A1:B6 of a sheet named home; titles in column A, subtitles in column B.


```
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:\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")
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 = Sheets("home").[a1].Offset(sn - 1)
sl.Shapes(1).TextFrame.VerticalAnchor = msoAnchorTop
sl.Shapes(2).TextFrame.TextRange.Text = Sheets("home").[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
End Sub
```


----------



## onthegreen03 (Nov 7, 2016)

Thanks Worf!   I'm glad you responded ... I thought maybe you saw my post and went running & screaming!  Ha Ha.    I'll try this out today and let you know how it works.   I've been using the code now for a week and it works GREAT.   Really the only issue I'd like to solve is being able to set up my titles and subtitles in an Excel sheet within that same file so the code pulls the text from there (as opposed to me changing the actual VBA code each time).   Stay tuned!


----------



## onthegreen03 (Nov 7, 2016)

Hi Worf - I tried the new code and I am getting an Excel error message that reads:  "Object library invalid or contains references to object definitions that could not be found".   I noticed that my "RunAllMacros" had to have the new "FormatSlide (sn)" procedure added.  So now that macro runs all 3 procedures.  I also added the "Home" tab to the file so that is there.  Any idea what happened?   Let me know if sending you my files will make things easier.


----------



## Worf (Nov 7, 2016)

- My code does not call the slide formatting routine in that procedure; I am not sure what you are doing…
- Yes, please post your current code or email me the files.
- What line throws the error?


----------



## Worf (Nov 8, 2016)

Hi

(Email communication took place)
You will get the out of range error if that A1:B6 range is empty.
Please type something there and try again…


----------



## onthegreen03 (Nov 9, 2016)

Worf - I bow down to your Excel greatness.  Very nice!   As you predicted it worked once I added the text in those cells.   Last question.   If I end up having 10 slides do I just keep typing down?  So the range would extend to A1:B10 but I will not have to change the code correct?


----------



## Worf (Nov 10, 2016)

The code currently loops the elements of the sheet names array. Would you like to transfer all the arrays from the second procedure to a worksheet range?
This would eliminate value hardcoding in the VBA and the loop would be controlled by the range size.


----------



## onthegreen03 (Nov 10, 2016)

Worf - I think I am okay with leaving the code as is although I'm getting another (different) error when I try the new code in my master file.   I will send you an email now with my master Excel file (a lot more tabs) so you can test on your end.   The error code is a Compile Error which reads "Only comments may appear after End Sub, End Function, or End Property.   The code stops at the line Sub FormatSlide (sn).    Just so you are aware I did change the tab name with the titles from "Home" to "Titles".  I also have 15 tabs which are now part of the array instead of 6 in the test file.   Hopefully by checking over my master file instead of the test file we can finally wrap this up.   Sending email now.


----------



## onthegreen03 (Jun 30, 2016)

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 (Nov 11, 2016)

Hi

I tested your workbook at work with Excel 2013 and got various error messages and program crashes.
Now I am home and tested it with Office 2007 for a change; got inconsistent errors but also some successful executions. In short, your file/data cannot be trusted; it may be corrupted in some way.
My proposal is that you perform the following test: create a brand new workbook from scratch, with little or no data, paste the code there and see if a PowerPoint presentation is correctly created. Run it several times.
If all goes well, there is something wrong with your current workbook and/or data.
Tell me what happens.


----------



## onthegreen03 (Nov 12, 2016)

Okay. I will set up a new file on Monday and report the results.   What's weird is the code prior to the title tab being added seemed to work fine.  I would get an occasional hiccup but for the most part it worked.   Hopefully we can get this code working.  You've spent so much time on it and that is much appreciated by me!   Will contact you on Monday.


----------



## onthegreen03 (Nov 14, 2016)

Hi Worf - I did as you suggested and created a brand new Excel WB and pasted in the current code.  Initially I was getting a run time error message (Shapes.PasteSpecial: Invalid Request.  The specified data type is unavailable.)  I'm not sure why it happened but eventually it stopped and I ran the code 5-6 times in a row without a problem.   Maybe I forgot to close the generated PP deck?   So after I ran the code I made sure to close the PP before running the code again, that is when I had the 100% success rate.   All this being said it appears like my master file has some bad/corrupt data somewhere (as you predicted).  What is the best way to rectify?   Can I simply take this newly created file and copy the tabs from the other file?  Or do I have to build everything from scratch?   Starting from scratch would be tough as I spent weeks setting that file up, but you may tell me I have no choice.   Let me know what you think.   Thanks.


----------



## Worf (Nov 14, 2016)

Hi

-      I am glad things are looking brighter now.
-      My suggestion now is that you copy the already existing sheets, one at a time, testing the code before adding the next one.
-      Another idea to eliminate a potential problem: instead of running the macro via a shape, do it directly from the VBE.


----------



## onthegreen03 (Nov 15, 2016)

Hi - I added in the tabs from the old file and the new file seems to be working without errors.   THANK YOU again for your time and efforts to get this project completed.   I'll be in touch in a couple of days after I spend some time testing the new file.  I want to give you what I hope will be the final update.   Awesome job Worf!!


----------



## onthegreen03 (Nov 15, 2016)

Hi Worf - I did think of one thing as I was testing the code.   Can you add code at the end which adds slide numbers to each slide?   Right now after the code runs I manually go into "Insert/Slide Numbers" in PP and do it that way.   If that is something that is easy to add without much work do you mind adding that?   It would be a BIG help.


----------



## onthegreen03 (Nov 16, 2016)

Hi Worf - Just retagging this in case you did not get notification.   I know its happened in the past with you and me as well.    Thanks.


----------



## Worf (Nov 19, 2016)

This version adds slide numbers:


```
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:\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")
rad = Array("B7:T33", "B7:K33", "B3:P39", "B3:P39", "B3:P39", "B2:P36")
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
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("home").[a1].Offset(sn - 1)
sl.Shapes(1).TextFrame.VerticalAnchor = msoAnchorTop
sl.Shapes(2).TextFrame.TextRange.Text = Sheets("home").[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 = mypres.PageSetup.SlideWidth - 20
    .TextFrame.TextRange.Text = sl.SlideIndex
End With
End Sub
```


----------



## onthegreen03 (Nov 21, 2016)

Worf - Thank you for working on this (again) and adding slide numbers.   It did add slide numbers but I would like to ask for a couple of modifications in terms of placement and format.

1.  Right now the macro is adding slide numbers to the lower right part of the slide .... can you change it to the lower left?

2.  The slide number is coming in with a blue fill and white font color.   Can you get rid of the fill and change the font color to black?  

3.  The text size is 18 .... can you lower it to 10 and italicize it?

4.  Slide 2 has a slide number of 1 (I guess it doesn't account for the title page).  Can you change the code so it starts adding numbers on slide 2 (with the slide number of 2)?   I obviously do not want a slide number added to the title page but do want the numbering to start at 2 (slide 2).

If 2 and 3 prove to be too difficult let me know.  I remember the last time I asked you to change the format of the subtitle box it created a lot of extra work for you.  Also, I know you have a day job so I'll be patient and await your response even if it takes some time.   

Thanks again !


----------



## Worf (Nov 22, 2016)

> you have a day job



Yes, that is a problem... 


```
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 "d:\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")
rad = Array("B7:T33", "B7:K33", "B3:P39", "B3:P39", "B3:P39", "B2:P36")
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"
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("home").[a1].Offset(sn - 1)
sl.Shapes(1).TextFrame.VerticalAnchor = msoAnchorTop
sl.Shapes(2).TextFrame.TextRange.Text = Sheets("home").[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 = 12
    .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 = 10
    .TextFrame.TextRange.Font.Italic = msoTrue
End With
End Sub
```


----------



## onthegreen03 (Jun 30, 2016)

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


----------



## onthegreen03 (Nov 22, 2016)

inacreditável & obrigado!

Worf, you are a master of your craft.   I can't thank you enough for your time and efforts.  The macro is a work of art and works beautifully.   I'll try to not contact you again but I hope you don't mind if I do should I need some help down the road.   Thanks again.


----------



## onthegreen03 (Mar 14, 2022)

Worf said:


> Yes, that is a problem...
> 
> 
> ```
> ...


Hey Worf.  You likely will not remember be but you helped me back in 2016 with some Excel to PP coding, which turned out great by the way.  I am trying to copy that old code into a new file but am having issues getting it to work.  If you get this and have a few seconds let me know and I'll send you the exact issue.   Thanks.


----------

