从包含文本框和表格的 PowerPoint 幻灯片中提取文本以粘贴到 Excel 工作表中

Question

我是 Excel vba 的新手，正在尝试调整下面的代码以从 PPT 文件中提取文本并将所有文本粘贴到 Excel 工作表。从带有表格的幻灯片中提取数据的代码已经可以使用，但它无法从文本框或幻灯片标题中提取数据。源文件的前 2 个 PPT 幻灯片不包含任何表格。感谢您对此的帮助。

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

结束子

Answer 1

试试这个来提取文本而不是上面的内容：

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

从包含文本框和表格的 PowerPoint 幻灯片中提取文本以粘贴到 Excel 工作表中

Extract text from PowerPoint slides containing TextBox and Tables to paste in Excel worksheet

excel

powerpoint

vba

extract

export-to-excel