Selected Excel Range to Power Point Kinda...

Hi,

I cannot seem to figure this out for the life of me but I am hoping that someone in the forum may be able to help me.

I need to be able to send my selected range of cells (to include: the spreadsheet background, colored cells and all values contained) to Power Point for a daily product.

I found this great VBA online and would like to use it but the problem is I keep getting funny results. It doesn't matter what cells I select I keep getting a extra margin on the left side and top of the pasted product in power point. I then have to crop the results... I have looked at the macro (from my noodie eyes) and cannot seem to find a way to adjust this added on margin.

Does anybody know how I can fix this so that I do not have to crop the results in Power Point every time I use this macro?

Sub RangeToPresentation()
' Set a VBE reference to Microsoft PowerPoint Object Library
'Original code sourced from Jon Peltier http://peltiertech.com/Excel/XL_PPT.html

Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide

' Make sure a range is selected
If Not TypeName(Selection) = "Range" Then
    MsgBox "Please select a worksheet range and try again.", vbExclamation, _
        "No Range Selected"
Else
    ' Reference existing instance of PowerPoint
    Set PPApp = GetObject(, "Powerpoint.Application")
    ' Reference active presentation
    Set PPPres = PPApp.ActivePresentation
    PPApp.ActiveWindow.ViewType = ppViewSlide
    ' Reference active slide
    Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
    
    ' Copy the range as a piicture
    Selection.CopyPicture Appearance:=xlScreen, _
        Format:=xlPicture

    ' Paste the range
    PPSlide.Shapes.Paste.Select
    
    ' Align the pasted range
    PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
    PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True

    ' Clean up
    Set PPSlide = Nothing
    Set PPPres = Nothing
    Set PPApp = Nothing
End If

End Sub

NOTE: Select any range of cells, Selection is sent to Power Point, Power Point must be active. Due to Excel File size (tiled jpeg background) I was not able to post spreadsheet. But results are attached.

Any help with this would be really great.

Best Regards,

BusDriver2


Please see attached files.