Hi all
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 in Excel
i can extract data and paste it in excel
but the tables are printing one below other
like this
but i want the tables to to printed like this
how the tables are placed in ppt in same way the tables need to be printed in excel
i tried with this macro but didnt work
Option Explicit
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
how do i create a macro for this
thank you
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 in Excel
i can extract data and paste it in excel
but the tables are printing one below other
like this
but i want the tables to to printed like this
how the tables are placed in ppt in same way the tables need to be printed in excel
i tried with this macro but didnt work
Option Explicit
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
how do i create a macro for this
thank you