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