EXcel VBA : Excel Macro to create table in a PowerPoint - vba

Question

My requirement is I have a Excel which contains some data. I would like to select some data from the excel and open a PowerPoint file and
Create Table in PowerPoint and populate the data in to it
Right now I have succeeded in collecting the data from excel opening a PowerPoint file through Excel VBA Code.
Code for Opening the PowerPoint from Excel.
Set objPPT = CreateObject("Powerpoint.application")
objPPT.Visible = True
Dim file As String
file = "C:\Heavyhitters_new.ppt"
Set pptApp = CreateObject("PowerPoint.Application")
Set pptPres = pptApp.Presentations.Open(file)
Now how do I create the table in PowerPoint from Excel and populate the data.
Timely help will be very much appreciated.
Thanks in advance,

Answer 1

Here's some code from http://mahipalreddy.com/vba.htm
''# Code by Mahipal Padigela
''# Open Microsoft Powerpoint,Choose/Insert a Table type Slide(No.4), then double click to add a...
''# ...Table(3 Cols & 2 Rows) then rename the Table to "Table1", Save and Close the Presentation
''# Open Microsoft Excel, add some test data to Sheet1(This example assumes that you have some data in...
''# ... Rows 1,2 and Columns 1,2,3)
''# Open VBA editor(Alt+F11),Insert a Module and Paste the following code in to the code window
''# Reference 'Microsoft Powerpoint Object Library' (VBA IDE-->tools-->references)
''# Change "strPresPath" with full path of the Powerpoint Presentation created earlier.
''# Change "strNewPresPath" to where you want to save the new Presnetation to be created later
''# Close VB Editor and run this Macro from Excel window(Alt+F8)
Dim oPPTApp As PowerPoint.Application
Dim oPPTShape As PowerPoint.Shape
Dim oPPTFile As PowerPoint.Presentation
Dim SlideNum As Integer
Sub PPTableMacro()
Dim strPresPath As String, strExcelFilePath As String, strNewPresPath As String
strPresPath = "H:\PowerPoint\Presentation1.ppt"
strNewPresPath = "H:\PowerPoint\new1.ppt"
Set oPPTApp = CreateObject("PowerPoint.Application")
oPPTApp.Visible = msoTrue
Set oPPTFile = oPPTApp.Presentations.Open(strPresPath)
SlideNum = 1
oPPTFile.Slides(SlideNum).Select
Set oPPTShape = oPPTFile.Slides(SlideNum).Shapes("Table1")
Sheets("Sheet1").Activate
oPPTShape.Table.Cell(1, 1).Shape.TextFrame.TextRange.Text = Cells(1, 1).Text
oPPTShape.Table.Cell(1, 2).Shape.TextFrame.TextRange.Text = Cells(1, 2).Text
oPPTShape.Table.Cell(1, 3).Shape.TextFrame.TextRange.Text = Cells(1, 3).Text
oPPTShape.Table.Cell(2, 1).Shape.TextFrame.TextRange.Text = Cells(2, 1).Text
oPPTShape.Table.Cell(2, 2).Shape.TextFrame.TextRange.Text = Cells(2, 2).Text
oPPTShape.Table.Cell(2, 3).Shape.TextFrame.TextRange.Text = Cells(2, 3).Text
oPPTFile.SaveAs strNewPresPath
oPPTFile.Close
oPPTApp.Quit
Set oPPTShape = Nothing
Set oPPTFile = Nothing
Set oPPTApp = Nothing
MsgBox "Presentation Created", vbOKOnly + vbInformation
End Sub

Answer 2

This Excel-VBA exports the selected range from Excel to a PowerPoint native table. It also works with merged cells.
Sub Export_Range()
Dim pp As New PowerPoint.Application
Dim ppt As PowerPoint.Presentation
Dim sld As PowerPoint.Slide
Dim shpTable As PowerPoint.Shape
Dim i As Long, j As Long
Dim rng As Excel.Range
Dim sht As Excel.Worksheet
Set rng = Selection
pp.Visible = True
If pp.Presentations.Count = 0 Then
Set ppt = pp.Presentations.Add
Else
Set ppt = pp.ActivePresentation
End If
Set sld = ppt.Slides.Add(1, ppLayoutTitleOnly)
Set shpTable = sld.Shapes.AddTable(rng.Rows.Count, rng.Columns.Count)
For i = 1 To rng.Rows.Count
For j = 1 To rng.Columns.Count
shpTable.Table.Cell(i, j).Shape.TextFrame.TextRange.Text = _
rng.Cells(i, j).Text
Next
Next
For i = 1 To rng.Rows.Count
For j = 1 To rng.Columns.Count
If (rng.Cells(i, j).MergeArea.Cells.Count > 1) And _
(rng.Cells(i, j).Text <> "") Then
shpTable.Table.Cell(i, j).Merge _
shpTable.Table.Cell(i + rng.Cells(i, j).MergeArea.Rows.Count - 1, _
j + rng.Cells(i, j).MergeArea.Columns.Count - 1)
End If
Next
Next
sld.Shapes.Title.TextFrame.TextRange.Text = _
rng.Worksheet.Name & " - " & rng.Address
End Sub