VBA Code to move Ranges from Excel 2007 to PowerPoint 2007

[curtdawg]

Intended Purpose:<o></o>
· Transfer a specified 4 ranges or objects from2007 MS Excel to 2007 MS PowerPoint WITHOUT changing the personally set defaulttemplate set in PPT.
· Have the ability to control the size (height andwidth) of range on PPT slide, location of the ranges on PPT slide, which slidenumber to locate the four ranges/objects (prefer a prompt to guide location‘Indicate preferred slide number in which to import ranges?’)
· Have a prompt to ask ‘Would you like to Savethis PPT Presentation?’

Any help that you can offer with any/all of these three purposes/goals is VERY appreciated!




Sub FourRangesPerPPtSlide()

Dim PPApp As PowerPoint.Application
Dim PPSlide As PowerPoint.Slide
Dim SheetName As String
Dim RangePasteType As String
Dim RangeName1, RangeName2, RangeName3, RangeName4 As String

SheetName = ActiveSheet.Name
RangeName1 = "F2:I11"
RangeName2 = "K2:R21"
RangeName3 = "A1:C6"
RangeName4 = "A6:C12"

If PPApp Is Nothing Then Set PPApp = New PowerPoint.Application
If PPApp.Presentations.Count = 0 Then PPApp.Presentations.Add
PPApp.Visible = True

'Set First Slide With Two Ranges in Over/Under Format
Set PPSlide = PPApp.ActivePresentation.Slides.Add(1, ppLayoutBlank) I think this line is the problem to the first bullet specifically the (1, ppLayoutBlank)

'Top Left
Worksheets(SheetName).Range(RangeName1).Copy
With PPSlide.Shapes.PasteSpecial(ppPasteMetafilePicture)
.Align msoAlignLefts, True
.Align msoAlignTops, True
.Item(1).ScaleHeight 1, msoCTrue, msoScaleFromMiddle
End With

'Top Right
Worksheets(SheetName).Range(RangeName3).Copy
With PPSlide.Shapes.PasteSpecial(ppPasteMetafilePicture)
.Align msoAlignRights, True
.Align msoAlignTops, True
.Item(1).ScaleHeight 1, msoCTrue, msoScaleFromMiddle
End With

'Bottom Left
Worksheets(SheetName).Range(RangeName4).Copy
With PPSlide.Shapes.PasteSpecial(ppPasteMetafilePicture)
.Align msoAlignLefts, True
.Align msoAlignBottoms, True
.Item(1).ScaleHeight 1, msoCTrue, msoScaleFromMiddle
End With

'Bottom Right
Worksheets(SheetName).Range(RangeName2).Copy
With PPSlide.Shapes.PasteSpecial(ppPasteMetafilePicture)
.Align msoAlignRights, True
.Align msoAlignBottoms, True
.Item(1).ScaleHeight 1, msoCTrue, msoScaleFromMiddle
End With


With PPApp.ActivePresentation
.SaveAs ("C:\Users\cummingsc\Desktop\DataTransferFourRanges.ppt") 'Specify location and name of file for SaveAs procedure
End With

AppActivate ("Microsoft Powerpoint")

'Release Object Variable
Set PPSlide = Nothing
Set PPApp = Nothing

End Sub