在EXCEL 2010中复制和粘贴范围VBA PowerPoint

Question

This is the code that I am currently using. I want to copy and paste a range to a specific powerpoint. I can do this fine using the following code but the quality is not very good and I was hoping there is another way around this.

Sub This ()
Dim PPApp  As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide

        ' Reference existing instance of PowerPoint
Set PPApp = New PowerPoint.Application
Set pptPres = PPApp.Presentations.Open("C:\Desktop\Template.pptx")


Set PPApp = GetObject(, "Powerpoint.Application")
' Reference active presentation
Set PPPres = PPApp.ActivePresentation
Sheets("Test").Select
Range("B6:Q46").CopyPicture
' Paste the range
With PPPres.Slides(18).Shapes.PasteSpecial
                .Top = 86.8969
                .Left = 19.98417
                .Height = 150.7964
                .Width = 600.5262
End With
End Sub

I have tried this:

Sheets("Test").Select
Range("B6:Q46").Copy
' Paste the range
With PPPres.Slides(18).PasteSpecial
                .Top = 86.8969
                .Left = 19.98417
                .Height = 150.7964
                .Width = 600.5262
End With

But this does not work, and I was wondering if there is a way to do this. When I copy and paste I want to keep the formatting as well.

Addition

I have done some research online and I have seen that if I want to keep the formatting of the range and don't want to copy the range as a picture then I need to use:

ppapp.CommandBars.ExecuteMso ("PasteExcelTableSourceFormatting")

But I cannot get this to work this is what I am trying to do:

    Sub CreatePP()
    Dim ppapp As PowerPoint.Application
    Dim ppPres As PowerPoint.Presentation
    Dim ppSlide As PowerPoint.Slide
    Dim ppTextBox As PowerPoint.Shape
    Dim iLastRowReport As Integer
    Dim sh As Object
    Dim templatePath As String

Set ppapp = GetObject(, "PowerPoint.Application")

Set pptPres = PPApp.Presentations.Open("C:\Desktop\Template.pptx")
ppapp.Visible = True
Sheets("Tables").Select
Range("A27:D48").Copy

ppapp.ActivePresentation.Slides (5)
ppapp.CommandBars.ExecuteMso ("PasteExcelTableSourceFormatting")

Answer 1

Try pasting it as a EnhancedMetafile?

Set myShapeRange = PPPres.Slides(18).PasteSpecial(ppPasteEnhancedMetafile)
With myShapeRange
            .Top = 86.8969
            .Left = 19.98417
            .Height = 150.7964
            .Width = 600.5262
End With

Function parameters via https://msdn.microsoft.com/en-us/library/office/ff745158.aspx