PDA

View Full Version : Excel to PPT --- can't detect error in loop



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

Paul_Hossler
04-06-2016, 05:22 PM
1. Use the [#] icon to add CODE tags and paste macro between them please

2. Try this version - I have Office 2016



Option Explicit
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 ============================ changed names
MyRangeArray = Array(Sheet7.Range("A1:c10"), Sheet6.Range("A1:c10"), Sheet5.Range("A1:c10"), _
Sheet4.Range("A1:c10"), Sheet3.Range("A1:c10"), Sheet2.Range("A1:c10"), Sheet1.Range("a1:c10"))

'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

'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

'Clear The Clipboard
Application.CutCopyMode = False

Set shp = mySlide.Shapes(1)

'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

snb
04-07-2016, 03:56 AM
Sub M_snb()
sn = Array(Sheet1.Range("A1:g32"), [Sheet2!A1:g10], Sheet1.Range("A1:j27"), Sheet1.Range("A1:i31"), Sheet1.Range("A1:f15"), Sheet1.Range("A1:e17"))

With CreateObject("PowerPoint.Application")
.Visible = True
With .Presentations.Add
For j = 0 To UBound(sn)
With .Slides.Add(1, 12)
sn(j).Copy
.Shapes.PasteSpecial 2
.Shapes(1).Left = 30
.Shapes(1).Top = 30
End With
Next
End With
End With
End Sub

TexasAggie
04-07-2016, 10:10 AM
Thank you, Paul_Hossler! This worked perfectly. And thank you for the etiquette tip, too. This was my first ever post here.
elizabeth


1. Use the [#] icon to add CODE tags and paste macro between them please

2. Try this version - I have Office 2016



Option Explicit
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 ============================ changed names
MyRangeArray = Array(Sheet7.Range("A1:c10"), Sheet6.Range("A1:c10"), Sheet5.Range("A1:c10"), _
Sheet4.Range("A1:c10"), Sheet3.Range("A1:c10"), Sheet2.Range("A1:c10"), Sheet1.Range("a1:c10"))

'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

'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

'Clear The Clipboard
Application.CutCopyMode = False

Set shp = mySlide.Shapes(1)

'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

TexasAggie
04-07-2016, 10:37 AM
snb, thank you for this alternative. I was able to tweak it to my range and make it work perfectly. Thanks! elizabeth