如何将粘贴数据范围从 Excel 复制到 powerpoint 幻灯片

Question

我正在尝试准备代码以将 Excel 数据范围从 Excel 工作表复制和粘贴到 Powerpoint 幻灯片，但我只能粘贴图像。

请帮助提供合适的代码。我使用的代码如下：

Sub WorkbooktoPowerPoint()

    Dim pp As Object
    Dim PPPres As Object
    Dim PPSlide As Object
    Dim Rng As Range

    Set pp = CreateObject("PowerPoint.Application")
    Set PPPres = pp.Presentations.Add
    pp.Visible = True
    Set Rng = ActiveSheet.Range("B1:J31")

    Rng.Copy

    SlideCount = PPPres.Slides.Count
    Set PPSlide = PPPres.Slides.Add(SlideCount + 1, 12)

    PPSlide.Shapes.PasteSpecial ppPasteOLEObject
    PPSlide.Shapes(1).Select
    pp.ActiveWindow.Selection.ShapeRange.Align msoAlignTops, True
    pp.ActiveWindow.Selection.ShapeRange.Top = 65
    pp.ActiveWindow.Selection.ShapeRange.Left = 7.2
    pp.ActiveWindow.Selection.ShapeRange.Width = 700

    pp.Activate
    Set PPSlide = Nothing
    Set PPPres = Nothing
    Set pp = Nothing

End Sub

Answer 1

令我感到惊讶的是，许多PasteSpecial 选项通常在剪贴板或 PowerPoint 中不可用。我认为有一种方法可以使用不同的方法来解决这个问题。而不是：

PPSlide.Shapes.PasteSpecial ppPasteOLEObject

试试这个方法：

PPSlide.Parent.CommandBars.ExecuteMso "PasteExcelTableSourceFormatting"

我不确定要使用正确的 idMso 参数，但我会从它开始，它看起来像我期望的那样工作：

PowerPoint 结果

Excel 表格示例

如果没有，还有其他几个可能值得检查：

• PasteSourceFormatting
• 粘贴目的地主题
• PasteAsEmbedded
• 粘贴ExcelTableSourceFormatting
• 粘贴ExcelTableDestinationTableStyle

与许多其他方法相比，此方法的文档记录不充分。 Application.CommandBars property reference 没有提到 ExecuteMso 方法，我在这里找到了一些信息（以及我之前看到它使用过一次或两次的 SO）：

要探索的 idMso 参数的完整列表，它是一个相当大的可执行文件的一部分，用于流畅的功能区 UI 设计，我相信是 Office 2013 的当前版本：

http://www.microsoft.com/en-us/download/details.aspx?id=727

Answer 2

另一种无需 VBA 代码即可将数据从 Excel 获取到 PPT 幻灯片的方法也是可行的。

注意：将工作簿和 PPT 文件保存在一个位置。

第一步：复制excel数据/表格

第 2 步：转到 Power point 幻灯片

第 3 步：选择粘贴特殊选项

第 4 步：选择“粘贴链接”单选按钮

第 5 步：点击确定

然后保存文件然后在excel中更改数据，现在它会自动复制基于链接连接的数据。

希望此选项有所帮助。

谢谢， 美食家

Answer 3

要获取 Excel 范围并将其粘贴到 PowerPoint 应用程序中，需要将该过程分解为几个不同的部分。查看您的代码，我们可以将其分解为以下组件：

• 创建一个 PowerPoint 实例。
• 制作幻灯片和演示文稿。
• 创建对要导出的范围的引用，然后复制它。
• 将形状与所需尺寸对齐。
• 最后，从内存中释放对象。

我假设您希望将此代码保留为后期绑定，但您的代码中也有一些部分会导致问题，因为您将其视为在早期绑定中编写的。

另外，我有一个关于这个主题的 YouTube 视频，所以如果您想要进行更复杂的粘贴或使用多个 Excel 范围，请随时观看该系列。

播放列表链接： https://www.youtube.com/playlist?list=PLcFcktZ0wnNlFcSydYb8bI1AclQ4I38VN

第一部分：声明变量

在这里，我们将在脚本中创建我们需要的所有变量。

'Declare PowerPoint Variables
 Dim PPTApp As Object
 Dim PPTPres As Object
 Dim PPTSlide As Object

'Dim Excel Variables
 Dim ExcRng As Range

第二部分：创建一个新的 POWERPOINT 实例

这将创建一个新的 PowerPoint 应用程序，使其可见并使其成为活动窗口。

'Create a new PowerPoint Application and make it visible.
 Set PPTApp = CreateObject("PowerPoint.Application")
     PPTApp.Visible = True
     PPTApp.Activate

第三部分：创建新的演示文稿和幻灯片

这将向 PowerPoint 应用程序添加一个新演示文稿，在演示文稿中创建一个新幻灯片并将布局设置为空白布局。

'Create a new Presentation
Set PPTPres = PPTApp.Presentations.Add

'Create a new Slide
Set PPTSlide = PPTPres.Slides.Add(1, 12) '<<< THIS 12 MEANS A BLANK LAYOUT.

第四部分：创建对 EXCEL 范围的引用并复制它

这将设置对我们要复制和复制的 Excel 范围的引用。

'Set a reference to the range
Set ExcRng = Range("B1:J31")

'Copy Range
ExcRng.Copy

第四部分：在幻灯片中粘贴为对象

这会将范围粘贴到幻灯片中并设置对它的引用。

'Paste the range in the slide
 SET PPTShape = PPTSlide.Shapes.PasteSpecial(10) '<<< 10 means OLEOBJECT

第五部分：对齐形状

这将选择形状并设置它的尺寸。

'Select the shape.
PPTSlide.Shapes(PPTSlide.Shapes.Count).Select

'Set the Dimensions of the shape.
With PPTApp.ActiveWindow.Selection.ShapeRange
    .Top = 65
    .Left = 7.2
    .Width = 700
End With

第六部分：从内存中释放对象

这将从内存中释放对象。

'Erase Objects from memory.
Set PPTApp = Nothing
Set PPTSlide = Nothing
Set PPTShape = Nothing

总的来说，这就是您的代码现在的样子：

Sub ExportRangeToPowerPoint_Late()

    Dim PPTApp As Object
    Dim PPTPres As Object
    Dim PPTSlide As Object
    Dim PPTShape As Object

    Dim ExcRng As Range

    'Create a new instance of PowerPoint
    Set PPTApp = CreateObject("PowerPoint.Application")
        PPTApp.Visible = True
        PPTApp.Activate

    'Create a new Presentation
    Set PPTPres = PPTApp.Presentations.Add

    'Create a new Slide
    Set PPTSlide = PPTPres.Slides.Add(1, ppLayoutBlank)

    'Set a reference to the range
    Set ExcRng = Range("B1:J31")

    'Copy Range
    ExcRng.Copy

    'Paste the range in the slide
    Set PPTShape = PPTSlide.Shapes.PasteSpecial(10)

    'Select the shape.
    PPTSlide.Shapes(PPTSlide.Shapes.Count).Select

    'Set the Dimensions of the shape.
    With PPTApp.ActiveWindow.Selection.ShapeRange
        .Top = 65
        .Left = 7.2
        .Width = 700
    End With

    'Erase Objects from memory.
    Set PPTApp = Nothing
    Set PPTSlide = Nothing
    Set PPTShape = Nothing

End Sub