Powerpoint to excel using Powerpoint VBA [duplicate] - excel

Question

I have this challenge to create a macro to extract data from ppt.
I need to extract the data from tables in a ppt and paste them into Excel.
I can extract data and paste it into Excel, but the tables are printing one below the other, like this:
I want the tables to to printed like this:
The below image is from ppt how the tables are placed in ppt,
in similar way the tables need to be printed in the Excel spreadsheet:
I tried this:
Sub ExportToExcelSheet()
'Declare PPT variables
Dim pptPres As Presentation
Dim pptSlide As Slide
Dim pptShape As Shape
Dim pptPlaceholder As PlaceholderFormat
Dim pptTable As Table
'Declare Excel variables
Dim xlApp As Excel. Application
Dim xlBook As Excel. Workbook
Dim xlSheet As Excel. Worksheet
Dim xlRange As Excel.Range
'Access the active presentation
Set pptPres = Application.ActivePresentation
On Error Resume Next
Set xlApp = GetObject(, "EXCEL.Application")
If Err.Number = 429 Then
Err.Clear
Set xlApp = New Excel.Application
xlApp.Visible = True
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets.Add
End If
Set xlBook = xlApp.Workbooks("Extract.xlsx")
Set xlSheet = xlBook.Worksheets("Sheet1")
For Each pptSlide In pptPres.Slides
For Each pptShape In pptSlide.Shapes
If pptShape.Type = msoTable Then
Set pptTable = pptShape.Table
pptShape.Copy
Set xlRange = xlSheet.Range("A100").End(xlUp)
If xlRange.Address <> "$A$1" Then
Set xlRange = xlRange.Offset(3, 0)
End If
xlSheet.Paste Destination:=xlRange
End If
Next
Next
xlSheet.Columns.Range("A1").ColumnWidth = 5
xlSheet.Columns.Range("B1").ColumnWidth = 25
xlSheet.Rows.RowHeight = 20
End Sub

Answer 1

Because xlRange is defined by searching the last used cell in Column A, you are only pasting to Column A and thus, your current output is one after the other down this column.
You can keep it this way and then reposition each table after they are in Excel by serching each title for "Sub*" and if found put it on row (say) 10 otherwise using a similar method to your last row, find the last column and offset it say, 3 columns to the right.
Something like this AFTER your existing for loop...
Dim RowCounter As Long
Dim BottomRowOfTable As Long
Dim LastColumn As Long
Dim MyArray As Variant
For RowCounter = 1 To xlRange 'You can reuse this as the last destination which would be the last header row in the list you pasted.
With xlSheet
If .Cells(RowCounter, 1).Value Like "Sub*" Then
BottomRowOfTable = .Cells(RowCounter, 1).End(xlDown).Row
LastColumn = .Cells(8, .Columns.Count).End(xlToLeft).Column
MyArray = .Range(.Cells(RowCounter, 1), .Cells(BottomRowOfTable, 1)).Value
.Range(.Cells(8, LastColumn + 2).Address).Resize(UBound(MyArray)).Value = MyArray
.Range(.Cells(RowCounter, 1), .Cells(BottomRowOfTable, 1)).Clear
ElseIf .Cells(RowCounter, 1).Value Like "Station*" Then
BottomRowOfTable = .Cells(RowCounter, 1).End(xlDown).Row
LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
MyArray = .Range(.Cells(RowCounter, 1), .Cells(BottomRowOfTable, 1)).Value
.Range(.Cells(1, LastColumn + 2).Address).Resize(UBound(MyArray)).Value = MyArray
.Range(.Cells(RowCounter, 1), .Cells(BottomRowOfTable, 1)).Clear
End If
End With
Next RowCounter
You will probably need to change some of the cell references so it targets the right cell to find the title and/or move each table to the correct location.
I also did not test with formatting per your current output to Excel.
I think there is probably a cleaner way to do this but this method can achieve your goal.