TexasAggie
04-06-2016, 04:29 PM
Hello! In sending ranges to PPT from Excel (desired 7 slides, 1 metafile per slide), each of slides 1-6 is correct, but then slide 7 has its single metafile plus all 7 metafiles. It runs flawlessly but not how I intend it! What is my "For x" loop error? Thank you!
----------------------------------------------------------------------------------------------------------------------
Sub PasteMultipleSlides()
'PURPOSE: Copy Excel Ranges and Paste them into the Active PowerPoint presentation slides
'SOURCE: adapted from The Spreadsheet Guru
Dim myPresentation As Object
Dim mySlide As Object
Dim PowerPointApp As Object
Dim shp As Object
Dim MySlideArray As Variant
Dim MyRangeArray As Variant
Dim x As Long
'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 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
'List of PPT Slides to Paste to
MySlideArray = Array(1, 2, 3, 4, 5, 6, 7)
'List of Excel Ranges to Copy from
MyRangeArray = Array(Sheet7.Range("A1:h32"), Sheet14.Range("A1:g13"), Sheet5.Range("A1:j27"), _
Sheet10.Range("A1:i31"), Sheet6.Range("A1:f15"), Sheet4.Range("A1:e17"), Sheet1.Range("e1:P35"))
'Loop through Array data
For x = LBound(MySlideArray) To UBound(MySlideArray)
'Copy Excel Range
MyRangeArray(x).Copy
On Error Resume Next
'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, 12) '12 = ppLayoutBlank, 11 = ppLayoutTitleOnly, 1 = Title slide
'Paste to PowerPoint and position --- set variable to newly pasted shape
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set shp = myPresentation.Slides(MySlideArray(x)).Shapes.PasteSpecial(DataType:=2) 'Excel 2007-2010
Set shp = PowerPointApp.ActiveWindow.Selection.ShapeRange 'Excel 2013
On Error GoTo 0
'Center Object
With myPresentation.PageSetup
shp.Left = (.SlideWidth \ 2) - (shp.Width \ 2)
shp.Top = (.SlideHeight \ 2) - (shp.Height \ 2)
End With
Next x
PowerPointApp.Visible = True
PowerPointApp.Activate
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
----------------------------------------------------------------------------------------------------------------------
Sub PasteMultipleSlides()
'PURPOSE: Copy Excel Ranges and Paste them into the Active PowerPoint presentation slides
'SOURCE: adapted from The Spreadsheet Guru
Dim myPresentation As Object
Dim mySlide As Object
Dim PowerPointApp As Object
Dim shp As Object
Dim MySlideArray As Variant
Dim MyRangeArray As Variant
Dim x As Long
'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 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
'List of PPT Slides to Paste to
MySlideArray = Array(1, 2, 3, 4, 5, 6, 7)
'List of Excel Ranges to Copy from
MyRangeArray = Array(Sheet7.Range("A1:h32"), Sheet14.Range("A1:g13"), Sheet5.Range("A1:j27"), _
Sheet10.Range("A1:i31"), Sheet6.Range("A1:f15"), Sheet4.Range("A1:e17"), Sheet1.Range("e1:P35"))
'Loop through Array data
For x = LBound(MySlideArray) To UBound(MySlideArray)
'Copy Excel Range
MyRangeArray(x).Copy
On Error Resume Next
'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, 12) '12 = ppLayoutBlank, 11 = ppLayoutTitleOnly, 1 = Title slide
'Paste to PowerPoint and position --- set variable to newly pasted shape
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set shp = myPresentation.Slides(MySlideArray(x)).Shapes.PasteSpecial(DataType:=2) 'Excel 2007-2010
Set shp = PowerPointApp.ActiveWindow.Selection.ShapeRange 'Excel 2013
On Error GoTo 0
'Center Object
With myPresentation.PageSetup
shp.Left = (.SlideWidth \ 2) - (shp.Width \ 2)
shp.Top = (.SlideHeight \ 2) - (shp.Height \ 2)
End With
Next x
PowerPointApp.Visible = True
PowerPointApp.Activate
'Clear The Clipboard
Application.CutCopyMode = False
End Sub