Скопируйте и вставьте диапазон VBA PowerPoint в EXCEL 2010

Question

Это код, который я использую в настоящее время. Я хочу скопировать и вставить диапазон в конкретную точку питания. Я могу сделать это хорошо, используя следующий код, но качество не очень хорошее, и я надеялся, что есть другой путь.

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 

Я попытался это:

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 

Но это не работает, и мне было интересно, если есть способ сделать это. Когда я копирую и вставляю, я тоже хочу сохранить форматирование.

Добавление

Я сделал некоторые исследования в Интернет, и я видел, что, если я хочу, чтобы сохранить форматирование диапазона и не хочу, чтобы скопировать диапазон в качестве изображения, то мне нужно использовать:

ppapp.CommandBars.ExecuteMso ("PasteExcelTableSourceFormatting") 

Но я не могу получить эту работу, это то, что я пытаюсь сделать:

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

Попробуйте вставить его в EnhancedMetafile?

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

Параметры функции через https://msdn.microsoft.com/en-us/library/office/ff745158.aspx