Page 2 of 10 FirstFirst 1234 ... LastLast
Results 11 to 20 of 91

Thread: Macro to open Powerpoint and paste ranges from Excel - Troubleshoot error in code
Thanks Thanks: 0 Likes Likes: 0

  1. #11
    Board Regular Worf's Avatar
    Join Date
    Oct 2011
    Location
    Rio, Brazil
    Posts
    3,726
    Post Thanks / Like
    Mentioned
    6 Post(s)
    Tagged
    2 Thread(s)

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

    Sure. I'm waiting for your post...
    Excel 2013 / Windows 8.1 (home)
    Excel 2013 / windows 7 (work)


  2. #12
    Board Regular
    Join Date
    Jun 2016
    Posts
    56
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

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

    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

  3. #13
    Board Regular Worf's Avatar
    Join Date
    Oct 2011
    Location
    Rio, Brazil
    Posts
    3,726
    Post Thanks / Like
    Mentioned
    6 Post(s)
    Tagged
    2 Thread(s)

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

    Please test this:

    Code:
    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
    Excel 2013 / Windows 8.1 (home)
    Excel 2013 / windows 7 (work)


  4. #14
    Board Regular
    Join Date
    Jun 2016
    Posts
    56
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

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

    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.

  5. #15
    Board Regular Worf's Avatar
    Join Date
    Oct 2011
    Location
    Rio, Brazil
    Posts
    3,726
    Post Thanks / Like
    Mentioned
    6 Post(s)
    Tagged
    2 Thread(s)

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

    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.

    Code:
    ' 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
    Excel 2013 / Windows 8.1 (home)
    Excel 2013 / windows 7 (work)


  6. #16
    Board Regular
    Join Date
    Jun 2016
    Posts
    56
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

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

    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.

  7. #17
    Board Regular Worf's Avatar
    Join Date
    Oct 2011
    Location
    Rio, Brazil
    Posts
    3,726
    Post Thanks / Like
    Mentioned
    6 Post(s)
    Tagged
    2 Thread(s)

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

    Does this fix it?

    Code:
    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)
        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
    Excel 2013 / Windows 8.1 (home)
    Excel 2013 / windows 7 (work)


  8. #18
    Board Regular
    Join Date
    Jun 2016
    Posts
    56
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

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

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

  9. #19
    Board Regular Worf's Avatar
    Join Date
    Oct 2011
    Location
    Rio, Brazil
    Posts
    3,726
    Post Thanks / Like
    Mentioned
    6 Post(s)
    Tagged
    2 Thread(s)

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

    This one should produce a three slide presentation:

    Code:
    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
    Excel 2013 / Windows 8.1 (home)
    Excel 2013 / windows 7 (work)


  10. #20
    Board Regular
    Join Date
    Jun 2016
    Posts
    56
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

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

    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

Some videos you may like

User Tag List

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •