mtrilce
12-10-2016, 09:45 AM
Dear Friends,
I would like to modify this macro so that each slide generated in the PPT file is titled the same name as the graphics or tables copied on that slide:
Option Explicit
'PURPOSE: Copy/Paste An Excel Range Into a New PowerPoint Presentation
'SOURCE: www.TheSpreadsheetGuru.com
Dim PowerPointApp As Object
Dim myPresentation As Object
Sub ExcelRangeToPowerPoint()
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
'Optimize Code
Application.ScreenUpdating = False
'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add
'copy worksheets into slide
Call InsertSlideAndCopy(Worksheets("Company Data").Range("A5:C16")) '-----------------
Call InsertSlideAndCopy(Worksheets("Company Data").Shapes("Graph1")) '-----------------
Call InsertSlideAndCopy(Worksheets("Company Data (2)").Range("B2:D13"))
Call InsertSlideAndCopy(Worksheets("Company Data (3)").Range("C3:E14"))
Call InsertSlideAndCopy(Worksheets("Company Data (4)").Range("D4:F15"))
'Make PowerPoint Visible and Active
PowerPointApp.Visible = True
PowerPointApp.Activate
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
Private Sub InsertSlideAndCopy(O As Object)
Dim mySlide As Object, myShape As Object
'Add a slide to the Presentation
Set mySlide = myPresentation.slides.Add(myPresentation.slides.Count + 1, 11) '11 = ppLayoutTitleOnly '----------------
'Copy Excel Range
O.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
End Sub
I will greatly appreciate your help.
Regards,
Marcela
I would like to modify this macro so that each slide generated in the PPT file is titled the same name as the graphics or tables copied on that slide:
Option Explicit
'PURPOSE: Copy/Paste An Excel Range Into a New PowerPoint Presentation
'SOURCE: www.TheSpreadsheetGuru.com
Dim PowerPointApp As Object
Dim myPresentation As Object
Sub ExcelRangeToPowerPoint()
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
'Optimize Code
Application.ScreenUpdating = False
'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add
'copy worksheets into slide
Call InsertSlideAndCopy(Worksheets("Company Data").Range("A5:C16")) '-----------------
Call InsertSlideAndCopy(Worksheets("Company Data").Shapes("Graph1")) '-----------------
Call InsertSlideAndCopy(Worksheets("Company Data (2)").Range("B2:D13"))
Call InsertSlideAndCopy(Worksheets("Company Data (3)").Range("C3:E14"))
Call InsertSlideAndCopy(Worksheets("Company Data (4)").Range("D4:F15"))
'Make PowerPoint Visible and Active
PowerPointApp.Visible = True
PowerPointApp.Activate
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
Private Sub InsertSlideAndCopy(O As Object)
Dim mySlide As Object, myShape As Object
'Add a slide to the Presentation
Set mySlide = myPresentation.slides.Add(myPresentation.slides.Count + 1, 11) '11 = ppLayoutTitleOnly '----------------
'Copy Excel Range
O.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
End Sub
I will greatly appreciate your help.
Regards,
Marcela