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

Question

I have PowerPoint file with multiple tables, and I am trying to write an excel vba code to open the file, loop through the slides and shapes, and then transfer the tables into excel. For this purpose I just want to know how to loop through a slide and transfer any and all shapes/tables to excel.

Here is my current code:

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

I currently get the following Run-Time Error on the line "For Each s In Active Presentation.Slides": Run-time error '429': ActiveX component can't create object

I have looked around for examples, but I can only find examples of how to transfer tables from excel to PowerPoint, but not the other way around.

Answer 1

Lots of problems with your code:

• You are mixing late binding and early binding . While this is possible, it makes no sense. I assume that you already have a reference to the PowerPoint-Library added (else the type Slide would be invalid and the compiler would complain), so no need to declare objPPT as Object and use CreateObject . It's much better to declare pptApp as PowerPoint.Application and simply use the new -command.
• You create two Powerpoint-Aplication Objects (two calls to CreateObject("PowerPoint.Application") )
• Obviously you don't use Option Explicit . You should. Always. You assign a workbook to the variable wbk but later use wbk2 . Same with wsh vs. wsh2 . Let the compiler help you find those problems.
• Excel does not know something about ActivePresentation (and this is where your error comes from). You could use pptApp.ActivePresentation , but this is not necessary as you have already a reference to the presentation in pptPres .

Assuming early binding , your code could look like

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