从PowerPoint幻灯片中提取文本,其中包含要粘贴到Excel工作表中的文本框和表格
我是Excel vba新手,尝试调整下面的代码,从PPT文件中提取文本并将所有文本粘贴到Excel工作表。从带有表格的幻灯片中提取数据的代码已经运行,但无法从文本框或幻灯片标题中提取数据。源文件的前两张PPT幻灯片不包含任何表格。谢谢你在这方面的帮助从PowerPoint幻灯片中提取文本,其中包含要粘贴到Excel工作表中的文本框和表格,excel,vba,powerpoint,extract,export-to-excel,Excel,Vba,Powerpoint,Extract,Export To Excel,我是Excel vba新手,尝试调整下面的代码,从PPT文件中提取文本并将所有文本粘贴到Excel工作表。从带有表格的幻灯片中提取数据的代码已经运行,但无法从文本框或幻灯片标题中提取数据。源文件的前两张PPT幻灯片不包含任何表格。谢谢你在这方面的帮助 Sub DataTransfer() Dim shp As Shape, i%, j% Dim colCount As Integer Dim rowCount As Integer Dim rowNum As Integer Dim rn
Sub DataTransfer()
Dim shp As Shape, i%, j%
Dim colCount As Integer
Dim rowCount As Integer
Dim rowNum As Integer
Dim rng As Object
Set rng = GetObject(, "Excel.Application").Range("A1") ' start at top of worksheet
For i = 1 To ActivePresentation.Slides.Count
For Each shp In ActivePresentation.Slides(i).Shapes
If shp.HasTextFrame Then
If shp.Type = msoTextBox Then
rng.Value = shp.Shapes.TextFrame.TextRange
Set rng = rng.Offset(rowNum + 1) ' 1 blank row between tables
End If
End If
Next shp
Next i
For i = 3 To ActivePresentation.Slides.Count
For Each shp In ActivePresentation.Slides(i).Shapes
If shp.HasTable Then
With shp.Table
colCount = .Columns.Count
rowCount = .Rows.Count
On Error Resume Next
For rowNum = 0 To .Rows.Count - 1
For j = 0 To 7
rng.Offset(rowNum, j).Value = (.Cell(rowNum + 1, j + 1).Shape.TextFrame.TextRange)
Next j
'rng.Offset(rowNum, 4).Interior.Color = (.Cell(rowNum + 1, 5).Shape.TextFrame.TextRange)
Next rowNum
Set rng = rng.Offset(rowNum + 1) ' 1 blank row between tables
End With
End If
Next shp
Next i
End Sub尝试以下方法提取文本,而不是上面的内容:
For i = 1 To ActivePresentation.Slides.Count
For Each shp In ActivePresentation.Slides(i).Shapes
If shp.HasTextFrame Then
' Shapes other than textbox types can contain text
If shp.TextFrame.HasText Then
rng.Value = shp.TextFrame.TextRange.Text
Set rng = rng.Offset(rowNum + 1) ' 1 blank row between tables
End If
End If
Next shp
Next i
谢谢你,史蒂夫。