Consulting

Results 1 to 3 of 3

Thread: Need Help on Macro to Copy Shape and Paste into PowerPoint

  1. #1
    VBAX Regular
    Joined
    Jan 2012
    Posts
    11
    Location

    Need Help on Macro to Copy Shape and Paste into PowerPoint

    Hello Folks

    I have got a macro that copies Excel Sheets and pastes onto Powerpoint which works fine, however I have specific sheets which
    holds Grouped Shapes (Basically Excel Chart with some Text Boxes) in which case the macro fails.
    I have reasonably searched various articles and forums but was not able to resolve.

    Appreciate if someone can tweak my code.

    Sub ExporttoPPT()
    
    'variables
    Dim pp As Object
    Dim PPPres As Object
    Dim PPSlide As Object
    Dim xlwksht As Worksheet
    Dim Xchart As Excel.ChartObject
    Dim xlShape As Object
    Dim SlideCount As Long
    Dim row As Long
    
    'pp variable = Create a new powerpoint presentation
    Set pp = CreateObject("PowerPoint.Application")
    
    'Powerpoint presentation = add the object (the finished product) to the poewrpoint presentation
    Set PPPres = pp.Presentations.Add
    
    'powerpoint is now visible
    pp.Visible = True
    
    'Hide specific Sheets to generate the Pack
    
    For Each wsname In Array(Sheet1.Name, Sheet2.Name, Sheet3.Name, Sheet41.Name)
        Worksheets(wsname).Visible = False
        Next
    
    
    'range you pick for selection
    MyRange = ActiveSheet.PageSetup.PrintArea
    
    'For each worksheet in the active workbook select all the worksheets and wait however many seconds
    For Each xlwksht In ActiveWorkbook.Worksheets
      If xlwksht.Visible = True Then
        xlwksht.Select
        Application.Wait (Now + TimeValue("0:00:1"))
        
        'copy the picture from the range you selected
        
        ' Check if there is a shape in the activesheet
        If ActiveSheet.Shapes.Count > 0 Then
          
         ActiveSheet.Shapes("Group1").Select
         
         'Appearance:=xlScreen, Format:=xlPicture
    
            Else
    
        
        MyRange = ActiveSheet.PageSetup.PrintArea
            
        xlwksht.Range(MyRange).CopyPicture _
        Appearance:=xlScreen, Format:=xlPicture
        
         End If
    
        'Slide count
        SlideCount = PPPres.Slides.Count
        Set PPSlide = PPPres.Slides.Add(SlideCount + 1, 12)
        PPSlide.Select
    
        'paste the shapes
        PPSlide.Shapes.Paste
        pp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = True
        pp.ActiveWindow.Selection.ShapeRange.Top = 20
        pp.ActiveWindow.Selection.ShapeRange.Left = 20
        pp.ActiveWindow.Selection.ShapeRange.Width = 700
        pp.ActiveWindow.Selection.ShapeRange.Height = 350
    
    
    
    End If
    Next xlwksht
    
    pp.Activate
    
     
    'Cleans it up
    Set PPSlide = Nothing
    Set PPPres = Nothing
    Set pp = Nothing
    
    
    Sheet1.Visible = True
    End Sub

  2. #2
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    3,970
    Location
    Cross-posted at: https://www.excelforum.com/excel-pro...owerpoint.html
    Please read VBA Express' policy on Cross-Posting in Rule 3: http://www.vbaexpress.com/forum/faq...._new_faq_item3
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  3. #3
    Moderator VBAX Guru Aussiebear's Avatar
    Joined
    Dec 2005
    Location
    Queensland
    Posts
    3,834
    Location
    Quote Originally Posted by Mysore View Post

    I have reasonably searched various articles and forums but was not able to resolve.
    Given your level of experience in forums..... I am left wondering why you would cross post without informing those members of your having done so?
    Remember To Do the Following....
    Use tags when posting code to the thread,
    Mark your thread as Solved if satisfied by using the Thread Tools options.
    If posting the same issue to another forum please show the link

Posting Permissions

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