Powerpoint VBA从表中复制文本

Question

我正在尝试创建一个宏，该宏将从幻灯片中的所有表中复制文本。我可以选择表格，但无法从表格中复制文本条目。我需要将复制的文本粘贴到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