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
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