Powerpoint VBA 从表格中复制文本

Question

我正在尝试创建一个宏来复制幻灯片中所有表格中的文本。 我可以 select 表格但未能从表格中复制文本条目。 我需要将复制的文本粘贴到 excel 电子表格中。

这是脚本：

Option Explicit

Sub GetTableNames()

    Dim pptpres As Presentation
    Set pptpres = ActivePresentation
    
    Dim pptSlide As Slide
    Set pptSlide = Application.ActiveWindow.View.Slide
    
    Dim pptShapes As Shape
    Dim pptTable As Table
    
    For Each pptSlide In pptpres.Slides
        For Each pptShapes In pptSlide.Shapes
            If pptShapes.HasTable Then
                Set pptTable = pptShapes.Table
                pptShapes.Select msoFalse
                pptShapes.TextFrame.TextRange.Copy
            End If
        Next
    Next

End Sub

在此处输入图像描述

在此处输入图像描述

Answer 1

试试这个代码：

Sub GetTableNames()

    Dim pptpres As Presentation
    Set pptpres = ActivePresentation
    
    Dim pptSlide As Slide
    Set pptSlide = Application.ActiveWindow.View.Slide
    
    Dim pptShapes As Shape, pptTable As Table
    
    Dim XL As Object, WS As Object
    Dim arr As Variant, nextTablePlace As Integer, cnt As Integer
    
    Set XL = CreateObject("Excel.Application")
    With XL.Workbooks.Add
        Set WS = .Worksheets(1)
    End With
    
    nextTablePlace = 1  ' to output first table content into Worksheet
    
    For Each pptSlide In pptpres.Slides
        For Each pptShapes In pptSlide.Shapes
            If pptShapes.HasTable Then
                cnt = cnt + 1
                Set pptTable = pptShapes.Table
                WS.Cells(nextTablePlace, 1) = "Table #: " & cnt ' caption for each table
                nextTablePlace = nextTablePlace + 1
                ReDim arr(1 To pptTable.Rows.Count, 1 To pptTable.Columns.Count) ' resize array to table dimensions
                For rr = 1 To pptTable.Rows.Count
                    For cc = 1 To pptTable.Columns.Count
                        arr(rr, cc) = pptTable.Cell(rr, cc).Shape.TextFrame.TextRange.Text   'get text from each cell into array
                    Next
                Next
                
                ' flush the arr to Worksheet
                WS.Cells(nextTablePlace, 1).Resize(pptTable.Rows.Count, pptTable.Columns.Count) = arr
                
                ' to next place with gap
                nextTablePlace = nextTablePlace + pptTable.Rows.Count + 2
            End If
        Next
    Next
    XL.Visible = True
End Sub