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

Question

I'm new to Excel vba and trying to tweak the code below to extract text from PPT file and paste all texts to Excel worksheet. The code to extract the data from slides with Tables already worked but it can't extract data from textboxes or slide titles. The first 2 PPT slides of the source file do not contain any tables. Appreciate your help on this.

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

Answer 1

Try this for extracting text rather than what you have above:

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