VBA 将表格从 PowerPoint 复制和粘贴到 Excel

Question

我有包含多个表格的 PowerPoint 文件，我正在尝试编写一个 excel vba 代码来打开文件，遍历幻灯片和形状，然后将表格传输到 excel 中。为此，我只想知道如何循环播放幻灯片并将任何和所有形状/表格传输到 Excel。

这是我当前的代码：

Sub PP_Test()
Dim s As Slide
Dim sh As Shape
Dim wbk As Workbook
Dim wsh As Worksheet

 Set objPPT = CreateObject("Powerpoint.application")
 objPPT.Visible = True
 Dim file As String
 file = "C:\Example.pptx"
 Set pptApp = CreateObject("PowerPoint.Application")
 Set pptPres = pptApp.Presentations.Open(file)
 Set wbk = Workbooks("Test.xlsm")

'Loop through the slides and loop through the shapes to find all the Tables. Copy the table, and paste them in Excel
For Each s In ActivePresentation.Slides
For Each sh In s.Shapes
'Create a new sheet in Excel
Set wsh = wbk.Worksheets.Add(After:=wbk2.Worksheets(wbk2.Worksheets.Count))
' Copy/paste the shape/table
sh.Copy
wsh2.Paste
Next sh
Next s

End Sub

我目前在“For Each s In Active Presentation.Slides”行中遇到以下运行时错误： 运行时错误“429”：ActiveX 组件无法创建对象

我四处寻找示例，但我只能找到如何将表格从 excel 传输到 PowerPoint 的示例，反之则找不到。

Answer 1

你的代码有很多问题：

• 您正在混合后期绑定和早期绑定。虽然这是可能的，但没有任何意义。我假设您已经添加了对 PowerPoint-Library 的引用（否则 Slide 类型将无效并且编译器会抱怨），因此无需将 objPPT 声明为 Object 并使用 CreateObject。最好声明 pptApp as PowerPoint.Application 并简单地使用 new-command。
• 您创建了两个 Powerpoint 应用程序对象（两次调用 CreateObject("PowerPoint.Application")）
• 显然你不使用Option Explicit。你应该。总是。您将工作簿分配给变量wbk，但后来使用wbk2。与wsh 与wsh2 相同。让编译器帮你找出这些问题。
• Excel 对ActivePresentation 不了解（这就是您的错误的来源）。您可以使用pptApp.ActivePresentation，但这不是必需的，因为您已经参考了pptPres 中的演示文稿。

假设早期绑定，您的代码可能看起来像

Sub PP_Test()
    Const filename = "C:\Example.pptx"

    Dim wbk As Workbook, wsh As Worksheet
    
    Dim pptApp As PowerPoint.Application, pptPres As PowerPoint.Presentation
    Set pptApp = new PowerPoint.Application
    pptApp.Visible = True
        
    Set pptPres = pptApp.Presentations.Open(filename)
    
    Set wbk = Workbooks("Test.xlsm")
    
    'Loop through the slides and loop through the shapes to find all the Tables. Copy the table, and paste them in Excel
    Dim s As PowerPoint.Slide, sh As PowerPoint.Shape
    For Each s In pptPres.Slides
        For Each sh In s.Shapes
            'Create a new sheet in Excel
            Set wsh = wbk.Worksheets.Add(After:=wbk.Worksheets(wbk.Worksheets.Count))
            ' Copy/paste the shape/table
            sh.Copy
            wsh.Paste
        Next sh
    Next s
End Sub