Excel 到 PowerPoint PasteSpecial 并保持源格式

Posted 2023-02-19

【中文标题】Excel 到 PowerPoint PasteSpecial 并保持源格式

【英文标题】：Excel to PowerPoint PasteSpecial and Keep Source Formatting

【发布时间】：2013-04-26 15:21:52

【问题描述】：

我正在尝试将 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

【问题讨论】：

您运行的是哪个版本的 Office？您的代码（除了一些缺失的行）看起来和工作正常。根据需要，我在 PP 演示文稿中有具有 excel 范围的 OLE 形状。所有格式都保留在源代码范围内...

我使用的是 2010。一切正常，除了复制时，它会复制 Excel 范围的一些边框。我需要使用没有单元格所有边框的源格式进行复制。

是否可以在没有 vba 的情况下手动执行？我不确定...我认为您需要更改源 Excel 文件中的单元格边框格式。

我该怎么做呢？我在 PowerPoint 上使用保留源格式进行了尝试，并且成功了。

你能上传一张你有什么和你需要什么的屏幕截图吗？

【参考方案1】：

让我们把这个问题分成几个不同的部分：

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

现在查看您的代码，您可以继续使用前两个代码。它正在粘贴导致问题的对象。让我们探索不同的粘贴方式。

使用 EXECUTEMSO 方法：

当我们使用这种方法时，就像我们在幻灯片上单击鼠标右键并将对象粘贴到幻灯片上一样。现在，虽然这种方法是一种完全有效的粘贴方式，但在 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 有足够的时间将信息放入剪贴板。通常不必长时间的停顿，但只有一两秒。下面是我们如何使用不同的选项来实现特殊粘贴方法：

'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

【讨论】：

ExecuteMso 之后的一个 DoEvents 似乎对于我的 Office 2013 来说已经足够了。

【参考方案2】：

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

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

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

【参考方案3】：

您是否尝试过使用

oPPTApp.ActiveWindow.View.PasteSpecial DataType:=ppPasteDefault

【参考方案4】：

试试这个解决方案，而不是使用Shapes.PasteSpecial 方法：

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

PPTApp.CommandBars.ExecuteMso "PasteExcelChartSourceFormatting"

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

【讨论】：

你好大卫，我一直在努力解决它，每当我使用 ExecuteMso 方法时，宏每次都会失败并出现不同的错误，但是 pastespecial 方法宏运行成功，但它不会给出源格式，我从 20 个 excel 表中粘贴总共 40 个形状。请帮忙。

@expfresh 请提交一个新问题，详细说明您的特定问题，包括您尝试使用的代码和错误描述以及哪些行会引发错误。请将此作为新问题提交，以便整个 SO 社区可以尝试帮助您。

【参考方案5】：

这是我的保持源格式的代码：

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

【讨论】：

如果您能解释一下基本思想是什么以及代码的作用而不是“仅仅”提供它，那将会更有帮助。