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

我正在尝试编写代码，以便将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

---

我仍然感到惊讶的是，许多

PasteSpecial

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

PPSlide.Shapes.PasteSpecial ppPasteOLEObject

尝试使用以下方法：

PPSlide.Parent.CommandBars.ExecuteMso "PasteExcelTableSourceFormatting"

我不确定要使用的

idMso

参数是否正确，但我首先要说的是，它的工作方式似乎与我预期的一样：

PowerPoint结果

Excel表格示例

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

• 粘贴源格式
• PasteDestinationHeme
• 粘贴嵌入
• 糊化
• 粘贴ExcelTableDestinationTableStyle

与许多其他方法相比，这种方法没有得到很好的证明。

Application.commandbar

中没有提到

ExecuteMso

方法，我在这里找到了一些相关信息（以及之前使用过一两次的地方）：

要探索的idMso参数的完整列表，作为与fluent ribbon UI设计一起使用的相当大的可执行文件的一部分，我相信，目前适用于Office 2013：

---

也可以使用另一种方法将数据从Excel获取到PPT幻灯片，而无需VBA代码

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

步骤1：复制excel数据/表格

步骤2：转到Power point幻灯片

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

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

第五步：点击Ok

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

希望这个选择有帮助

谢谢，

---

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

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

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

另外，我有一个关于这个主题的YouTube视频，所以如果你想做更复杂的粘贴或者使用多个Excel范围，请随意观看这个系列

链接到播放列表：

第一节：声明变量

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

'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.

第四部分：以对象形式粘贴幻灯片

这将在幻灯片中粘贴范围并设置对其的引用

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

第六节：从内存中释放对象

这将从内存中释放对象

'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

---

你有机会尝试我下面的建议吗？如果有效，请将答案标记为“已接受”，以便其他人可以从学习此方法中受益。David，我尝试过使用上述ExecuteMso方法，但没有运行。我有微软office 2013。是否有其他方法将excel范围复制为嵌入对象？Thanks@KanikeVamshiKrishna请提出一个新问题，而不是对别人的问题发表评论。问一个新问题将允许您提供重要的细节、代码示例等。如果您这样做，您可以在评论中标记我，如果可以，我将尽力提供帮助。

'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