Excel to PowerPoint PasteSpecial and Keep Source Formatting

Question

我正在尝试将Excel文档中的范围复制并粘贴到PowerPoint幻灯片中。

它将范围复制为图像，而不是保留源格式。

oPPTApp As PowerPoint.Application
Dim oPPTFile As PowerPoint.Presentation
Dim oPPTShape As PowerPoint.Shape
Dim oPPTSlide As PowerPoint.Slide
On Error Resume Next
Set XLApp = GetObject(, "Excel.Application")
On Error GoTo 0

Windows("File1.xlsx").Activate
Sheets("Sheet1").Select
Range("B3:N9").Select
Selection.Copy
oPPTApp.ActiveWindow.View.GotoSlide (2)
oPPTApp.ActiveWindow.Panes(2).Activate
oPPTApp.ActiveWindow.View.PasteSpecial DataType:=ppPasteOLEObject
oPPTApp.ActiveWindow.Selection.ShapeRange.Left = 35
oPPTApp.ActiveWindow.Selection.ShapeRange.Top = 150

Answer 1

将这个问题分为几个不同的部分：

• 创建PowerPoint应用程序
• 复制粘贴的图表
• 图表为正确的格式。

现在查看您的代码，前两个代码非常好。它会粘贴导致问题的对象。让我们探讨粘贴的不同方法。

使用执行方法：

[当我们使用此方法时，就像我们在幻灯片上单击鼠标右键并将对象粘贴到幻灯片上一样。现在，虽然此方法是完全有效的粘贴方法，但是在VBA中实现此方法可能会有些挑战。原因是因为它极不稳定，我们必须将脚本放慢到蜗牛的脚步！

要实现此方法及其任何不同的选项，请执行以下操作：

'Create a new slide in the Presentation, set the layout to blank, and paste range on to the newly added slide.
 Set PPTSlide = PPTPres.Slides.Add(1, ppLayoutBlank)

   'WARNING THIS METHOD IS VERY VOLATILE, PAUSE THE APPLICATION TO SELECT THE SLIDE
    For i = 1 To 5000: DoEvents: Next
    PPTSlide.Select

   'WARNING THIS METHOD IS VERY VOLATILE, PAUSE THE APPLICATION TO PASTE THE OBJECT
    For i = 1 To 5000: DoEvents: Next
    PPTApp.CommandBars.ExecuteMso "PasteSourceFormatting"
    PPTApp.CommandBars.ReleaseFocus

'PASTE USING THE EXCUTEMSO METHOD - VERY VOLATILE

'Paste As Source Formatting
'PPTApp.CommandBars.ExecuteMso "PasteSourceFormatting"

'Paste as Destination Theme
'PPTApp.CommandBars.ExecuteMso "PasteDestinationTheme"

'Paste as Embedded Object
'PPTApp.CommandBars.ExecuteMso "PasteAsEmbedded"

'Paste Excel Table Source Formatting
'PPTApp.CommandBars.ExecuteMso "PasteExcelTableSourceFormatting"

'Paste Excel Table Destination Theme
'PPTApp.CommandBars.ExecuteMso "PasteExcelTableDestinationTableStyle"

现在，如果您查看我的代码，我必须将其暂停两次，以确保它能正常工作。这是因为否则VBA的移动速度会太快，而发生的一切就是将所有对象粘贴到第一张幻灯片上！ 如果我们只做一个粘贴，通常情况下我们会很安全，而无需添加暂停，但要转到新幻灯片的那一刻，请添加暂停！]] >>

使用常规粘贴方法：

[当我们使用此方法时，就像我们按Crtl + V一样，它将简单地将对象粘贴为PowerPoint中的常规形状。常规形状表示PowerPoint中的默认粘贴类型。这是我们如何实现简单的粘贴方法的方法：

'PASTE USING PASTE METHOD - NOT AS VOLATILE

'Use Paste method to Paste as Chart Object in PowerPoint
 PPTSlide.Shapes.Paste
使用粘贴特殊方法：

当我们使用这种方法时，就像我们在键盘上按下Ctrl + Alt

+ V一样，我们得到了粘贴它的各种方法。 范围从图片一直到嵌入对象，我们可以将其链接回源工作簿。

[使用特殊粘贴方法，有时我们仍然不得不暂停脚本。

之所以像我上面提到的那样，VBA易变。 仅仅因为我们复制它并不意味着它会被复制到剪贴板中。此问题可能突然出现，然后同时消失，因此，我们最好的选择是在脚本中暂停一下，以使VBA有足够的时间将信息放入剪贴板。通常不必花很长时间暂停，但只有一秒钟或2秒。这是我们如何使用可以使用的不同选项来实现粘贴特殊方法的方法：

'PASTE USING PASTESPECIAL METHOD - NOT AS VOLATILE

'Paste as Bitmap
 PPTSlide.Shapes.PasteSpecial DataType:=ppPasteBitmap

'Paste as Default
 PPTSlide.Shapes.PasteSpecial DataType:=ppPasteDefault

'Paste as EnhancedMetafile
 PPTSlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile

'Paste as HTML - DOES NOT WORK WITH CHARTS
 PPTSlide.Shapes.PasteSpecial DataType:=ppPasteHTML

'Paste as GIF
 PPTSlide.Shapes.PasteSpecial DataType:=ppPasteGIF

'Paste as JPG
 PPTSlide.Shapes.PasteSpecial DataType:=ppPasteJPG

'Paste as MetafilePicture
 PPTSlide.Shapes.PasteSpecial DataType:=ppPasteMetafilePicture

'Paste as PNG
 PPTSlide.Shapes.PasteSpecial DataType:=ppPastePNG

'Paste as Shape
 PPTSlide.Shapes.PasteSpecial DataType:=ppPasteShape

'Paste as Shape, display it as an icon, change the icon label, and make it a linked icon.
 PPTSlide.Shapes.PasteSpecial DataType:=ppPasteShape, DisplayAsIcon:=True, IconLabel:="Link to my Chart", Link:=msoTrue

'Paste as OLEObject and it is linked.
 PPTSlide.Shapes.PasteSpecial DataType:=ppPasteOLEObject, Link:=msoFalse
话虽这么说，如果大多数情况下将对象粘贴为带有链接的OLEObject，格式就会随之消失。除非您有仅在Excel中存在的特殊主题，否则您将遇到麻烦。当我从Excel到Word绘制图表时遇到了这个问题，但是Excel图表具有自定义主题。
这是您的代码，已重写，以便它将使用源格式粘贴对象并设置其尺寸。

希望您不要介意我重新调整一些代码以使其更加简洁。

Sub PasteRangeIntoPowerPoint()

'Declare your variables
Dim oPPTApp As PowerPoint.Application
Dim oPPTFile As PowerPoint.Presentation
Dim oPPTShape As PowerPoint.Shape
Dim oPPTSlide As PowerPoint.Slide
Dim Rng As Range

'Get the PowerPoint Application, I am assuming it's already open.
Set oPPTApp = GetObject(, "PowerPoint.Application")

'Set a reference to the range you want to copy, and then copy it.
Set Rng = Worksheets("Sheet1").Range("B3:N9")
    Rng.Copy

'Set a reference to the active presentation.
Set oPPTFile = oPPTApp.ActivePresentation

'Set a reference to the slide you want to paste it on.
Set oPPTSlide = oPPTFile.Slides(3)

    'WARNING THIS METHOD IS VERY VOLATILE, PAUSE THE APPLICATION TO SELECT THE SLIDE
    For i = 1 To 5000: DoEvents: Next
    oPPTSlide.Select

    'WARNING THIS METHOD IS VERY VOLATILE, PAUSE THE APPLICATION TO PASTE THE OBJECT
    For i = 1 To 5000: DoEvents: Next
    oPPTApp.CommandBars.ExecuteMso "PasteSourceFormatting"
    oPPTApp.CommandBars.ReleaseFocus
    For i = 1 To 5000: DoEvents: Next

    'Set the dimensions of your shape.
    With oPPTApp.ActiveWindow.Selection.ShapeRange
        .Left = 35
        .Top = 150
    End With

End Sub

您是否尝试过使用

oPPTApp.ActiveWindow.View.PasteSpecial DataType:=ppPasteDefault

尝试使用此解决方案，而不要使用Shapes.PasteSpecial方法：

https://stackoverflow.com/a/19187572/1467082

PPTApp.CommandBars.ExecuteMso "PasteExcelChartSourceFormatting"
这不会创建指向Excel文档的链接，它会在PowerPoint演示文稿中嵌入文档的本地副本。我想我明白这是您的要求。

对于这种情况，我一直很高兴在Excel中使用Copy picture。要获取它，请单击Copy旁边的箭头。在VBA中，它翻译为

Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture

在较早版本的Excel（2003和更早版本）中，您需要单击Shift+Edit以获取该选项。

这是我的代码，保留源格式：

Sub SigAcc()
Application.ScreenUpdating = False
Dim myPresentation As Object
Set myPresentation = CreateObject("PowerPoint.Application")
Dim PowerPointApp As Object
Dim PPTApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Set objPPApp = New PowerPoint.Application

    Set PPSlide = myPresentation.ActivePresentation.Slides(2)


lastrow = ThisWorkbook.Worksheets("The worksheet you would like to copy").Range("Letter of longest column (E.I. "A")" & Rows.Count).End(xlUp).Row


For p = PPSlide.Shapes.Count To 1 Step -1
    Set myShape = PPSlide.Shapes(p)
    If myShape.Type = msoPicture Then myShape.Delete
    Next



Set myPresentation = myPresentation.ActivePresentation
Set mySlide = myPresentation.Slides(2)
On Error Resume Next


'assigning range into variable
Set r = ThisWorkbook.Worksheets("Sheet to copy").Range("A1:C" & lastrow)
On Error Resume Next

'If we have already opened powerpoint
Set PowerPointApp = GetObject(Class:="PowerPoint.Application")

'If Powerpoint is not opened
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(Class:="Powerpoint.Application")


r.Copy

'to paste range
PPApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
mySlide.Shapes.PasteSpecial
  Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
    'Set position:
      myShape.left = ActivePresentation.PageSetup.SlideWidth / 2 - ActivePresentation.PageSetup.SlideWidth / 2
      myShape.Top = 80
PowerPointApp.Visible = True
PowerPointApp.Activate


'to clear the cutcopymode from clipboard
Application.CutCopyMode = False

End Sub

Answer 2

您是否尝试过使用

Answer 3

尝试使用此解决方案，而不要使用Shapes.PasteSpecial方法：

Answer 4

对于这种情况，我一直很高兴在Excel中使用Copy picture。要获取它，请单击Copy旁边的箭头。在VBA中，它翻译为

Answer 5

这是我的代码，保留源格式：