VBA convert ppt to Excel

i have found two peice of codes but cannot get them together to work.

first code which extract text from text boxes it works without error.

Sub ExportTextToCSV()

  Dim oPres As Presentation
  Dim oSlides As Slides
  Dim oSld As Slide         'Slide Object
  Dim oShp As Shape         'Shape Object 
  Dim iFile As Integer      'File handle for output
  Dim sTempString As String

  Dim PathSep As String
  Dim Quote As String
  Dim Comma As String
  iFile = FreeFile          'Get a free file number

  #If Mac Then
    PathSep = ":"
  #Else
    PathSep = "\"
  #End If

  Quote = Chr$(34)
  Comma = ","

  Set oPres = ActivePresentation
  Set oSlides = oPres.Slides

  'Open output file
  ' NOTE:  errors here if original PPT file hasn't been saved
  Open oPres.Path & PathSep & "AllText.CSV" For Output As iFile

  For Each oSld In oSlides    'Loop thru each slide
    For Each oShp In oSld.Shapes                'Loop thru each shape on slide

      'Check to see if shape has a text frame and text
      If oShp.HasTextFrame And oShp.TextFrame.HasText Then
          sTempString = sTempString & Quote & oShp.TextFrame.TextRange.Text & Quote & Comma
      End If

    Next oShp

    ' print the result to file:
    Print #iFile, sTempString
    sTempString = ""

  Next oSld

  'Close output file
  Close #iFile

End Sub

Select allOpen in new window

second code which is for tables inside the slides, it kinda does not work. it gives error.

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.HasTable Then
                
                With shp.Table
                
'                    colCount = .Columns.Count
'                    rowCount = .Rows.Count
                    
                    For rowNum = 0 To .Rows.Count - 1
                          
                        For j = 0 To 4
                            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

Select allOpen in new window

Try something like this:

Sub TO_XL()
Dim osld As Slide
Dim L As Long
Dim XLapp As Object
Dim XLWB As Object
Dim rayData() As String
Dim char As Long
Dim iRow As Integer
Dim iCol As Integer
Dim myRange As Object
Set XLapp = CreateObject(Class:="Excel.Application")
XLapp.Visible = True
Set XLWB = XLapp.Workbooks.Add
XLWB.Sheets(1).Columns(1).ColumnWidth = 12
For L = 2 To 7
XLWB.Sheets(1).Columns(L).ColumnWidth = 25
Next L
Set myRange = XLWB.Sheets(1).Range("A1")
With XLWB.Sheets(1)
myRange.Offset(0, 0) = "STATE"
myRange.Offset(0, 1) = "(a)"
myRange.Offset(0, 2) = "(b)"
myRange.Offset(0, 3) = "(c)"
myRange.Offset(0, 4) = "(d)"
myRange.Offset(0, 5) = "(e)"
myRange.Offset(0, 6) = "(f)"
End With
iRow = 1
iCol = 1
For Each osld In ActivePresentation.Slides
ReDim rayData(1 To 1)
If osld.Shapes.HasTitle Then
rayData(1) = osld.Shapes.Title.TextFrame.TextRange
End If
With osld.Shapes(2).Table.Cell(1, 2).Shape.TextFrame2.TextRange
For L = 1 To .Paragraphs.Count
ReDim Preserve rayData(1 To UBound(rayData) + 1)
If .Paragraphs(L).ParagraphFormat.Bullet.Type = msoBulletNumbered Then
char = 96 + .Paragraphs(L).ParagraphFormat.Bullet.Number
rayData(UBound(rayData)) = "(" & Chr(char) & ")" & .Paragraphs(L).Text
Else
rayData(UBound(rayData)) = .Paragraphs(L).Text
End If
Next L
End With
myRange.Offset(iRow, 0) = rayData(1)
For L = 2 To UBound(rayData)
If Left(rayData(L), 3) = myRange.Offset(0, iCol).Text Then
myRange.Offset(iRow, iCol) = Mid(rayData(L), 4)
iCol = iCol + 1
End If
Next L
iRow = iRow + 1
iCol = 1
Next osld
End Sub

Select allOpen in new window

I would suggest that you NOT use excel but instead use access and to be brutally honest,
EE110116.accdb

thanks Wilson

i get error in line With osld.Shapes(2).Table.Cell(1, 2).Shape.TextFrame2.TextRange

method 'table' of object 'shape' failed

hi David,

i tried your solution and when i downloaded and tried to open it with Access. i get the following error.

can't find language DLL msain.dll

then i tried opening it via Open file from application. it opened and i do not see any macro in the database file.  how would i use this?

thanks David