VBA Question - Exporting table data from .ppt to excel

ickelly · Dec 26, 2013

Hi,

I've come up with the code below to find tables in a .ppt deck and save the data that I need in an array, but I'm having trouble exporting it to excel. I've referenced the excel library, and I think I have all the proper variables, but I must be missing some code. Any help is appreciated. Thanks, Ian

Code:

Sub DataTransfer()
Dim tb As Table
Dim shp As Shape, tg$, i%
Dim kid() As String
Dim start() As String
Dim target() As String
Dim actual() As String
Dim status() As String
Dim statForm() As String
Dim rowNum As Integer
Dim colNum As Integer
Dim colCount As Integer
Dim rowCount As Integer
Dim exApp As Excel.Application
Dim Cell As Excel.Range
Dim exWkSheet As Excel.Worksheet
Dim exWkBook As Excel.Workbook
 
    For i = 1 To ActivePresentation.Slides.Count
        tg = ""
            For Each shp In ActivePresentation.Slides(i).Shapes
                If shp.HasTable Then
                    tg = shp.Name       'finds first table
                    Exit For
                End If
    Next
    Select Case tg
        Case Is = ""
            MsgBox "Slide " & i & " has no tables", vbCritical
        Case Else
          Set tb = ActivePresentation.Slides(i).Shapes(tg).Table
          
          
          colNum = 1
          
          With tb
          
            colCount = .Columns.Count
            rowCount = .Rows.Count
              ReDim kid(rowCount)
              ReDim start(rowCount)
              ReDim target(rowCount)
              ReDim actual(rowCount)
              ReDim status(rowCount)
              ReDim statForm(rowCount)
                              
          
                    For rowNum = 1 To rowCount
                               
                        kid(rowNum) = (.Cell(rowNum, colNum).Shape.TextFrame.TextRange)
                        colNum = colNum + 1
                                                                 
                            start(rowNum) = (.Cell(rowNum, colNum).Shape.TextFrame.TextRange)
                            colNum = colNum + 1
                                
                                target(rowNum) = (.Cell(rowNum, colNum).Shape.TextFrame.TextRange)
                                colNum = colNum + 1
                                    
                                     actual(rowNum) = (.Cell(rowNum, colNum).Shape.TextFrame.TextRange)
                                     colNum = colNum + 1
                                             
                                             status(rowNum) = (.Cell(rowNum, colNum).Shape.TextFrame.TextRange)
                                             statForm(rowNum) = (.Cell(rowNum, colNum).Shape.TextFrame.TextRange)
                                             colNum = 1
                    Next rowNum
                   
           
            End With
        
        
    End Select
Next
                Set exApp = GetObject(, "Excel.Application")
                         With exApp.Selection
                         
                            .ActiveWorkbook.Activate
                            
                            .ActiveWorksheet.Select
                        
                            .ActiveCell.Select
                        
                            rowNum = 1
                                
                                
                                
                                For rowNum = 1 To rowCount
                                .ActiveCell.Value = kid(rowNum)
                                .ActiveCell.Offset(0, 1).Select
                                .ActiveCell.Value = start(rowNum)
                                .ActiveCell.Offset(0, 1).Select
                                .ActiveCell.Value = target(rowNum)
                                .ActiveCell.Offset(0, 1).Select
                                .ActiveCell.Value = actual(rowNum)
                                .ActiveCell.Offset(0, 1).Select
                                    With Selection
                                        .Value = status(rowNum)
                                        .Interior.Color = statForm(rowNum)
                                    End With
                                .ActiveCell.Offset(1, -4).Select
                                
                                Next rowNum
                                End With
                     
End Sub

Worf · Dec 31, 2013

Try this:

Code:

' this code goes at a PowerPoint module
Sub DataTransfer()
Dim tb As Table, shp As Shape, tg$, i%, ac As Excel.Range
Dim kid() As String, start() As String, target() As String, actual$()
Dim status() As String, statForm() As String
Dim rowNum As Integer, colNum As Integer, xlwb As Excel.Workbook
Dim colCount As Integer, rowCount%
Dim exApp As Excel.Application, Cell As Excel.Range
Dim exWkSheet As Excel.Worksheet, exWkBook As Excel.Workbook
 
    For i = 1 To ActivePresentation.Slides.Count
        tg = ""
            For Each shp In ActivePresentation.Slides(i).Shapes
                If shp.HasTable Then
                    tg = shp.Name       'finds first table
                    Exit For
                End If
    Next
    Select Case tg
        Case Is = ""
            MsgBox "Slide " & i & " has no tables", vbCritical
        Case Else
          Set tb = ActivePresentation.Slides(i).Shapes(tg).Table
          colNum = 1
          
          With tb
            colCount = .Columns.Count
            rowCount = .Rows.Count
              ReDim kid(rowCount)
              ReDim start(rowCount)
              ReDim target(rowCount)
              ReDim actual(rowCount)
              ReDim status(rowCount)
              ReDim statForm(rowCount)
            For rowNum = 1 To rowCount
                       
                kid(rowNum) = (.Cell(rowNum, colNum).Shape.TextFrame.TextRange)
                colNum = colNum + 1
                If colNum > colCount Then colNum = colCount
                start(rowNum) = (.Cell(rowNum, colNum).Shape.TextFrame.TextRange)
                colNum = colNum + 1
                If colNum > colCount Then colNum = colCount
                target(rowNum) = (.Cell(rowNum, colNum).Shape.TextFrame.TextRange)
                colNum = colNum + 1
                If colNum > colCount Then colNum = colCount
                actual(rowNum) = (.Cell(rowNum, colNum).Shape.TextFrame.TextRange)
                colNum = colNum + 1
                If colNum > colCount Then colNum = colCount
                status(rowNum) = (.Cell(rowNum, colNum).Shape.TextFrame.TextRange)
                statForm(rowNum) = (.Cell(rowNum, colNum).Shape.TextFrame.TextRange)
                colNum = 1
            Next rowNum
        End With
       End Select
Next
    Set exApp = GetObject(, "Excel.Application")
   Set xlwb = exApp.Workbooks.Open(ActivePresentation.Path & "\target.xlsm", , False)
   With xlwb.Worksheets("Sheet1")
        Set ac = .Range("x15")
        rowNum = 1
        For rowNum = 1 To rowCount
            If Len(kid(rowNum)) > 0 Then ac.Value = kid(rowNum)
            If Len(start(rowNum)) > 0 Then ac.Offset(, 1).Value = start(rowNum)
            ac.Offset(, 2).Value = target(rowNum)
            ac.Offset(, 3).Value = actual(rowNum)
            With ac.Offset(, 4)
                .Value = status(rowNum)
                If IsNumeric(statForm(rowNum)) Then .Interior.Color = statForm(rowNum)
            End With
            Set ac = ac.Offset(1)
        Next
    End With
    xlwb.Close True
    exApp.Quit
End Sub

VBA Question - Exporting table data from .ppt to excel

ickelly

New Member

Excel Facts

Worf

Well-known Member

Similar threads

Forum statistics

Share this page

VBA Question - Exporting table data from .ppt to excel

ickelly

New Member

Excel Facts

Worf

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock