Copy data from excel to paste in already existing tables of PPT template

If you want to copy the data from excel spreadsheet and paste it into existing table in PowerPoint Template. Snapshot below -

Input in Excel

Output in PPT Template




Here is the code-


Sub export_to_ppt()
' tools -> refrence select -> Microsoft powerpoint

Dim PPApp       As PowerPoint.Application
Dim PPPres      As PowerPoint.Presentation
Dim Shp         As Object
Dim i           As Integer

Set PPApp = New PowerPoint.Application

PPApp.Visible = True


For i = 3 To 4 ' chnage the first row and last row as per your data in Excel sheet

'open the powerpoint sample template
Set PPPres = PPApp.Presentations.Open(ThisWorkbook.Path & "\Sample_template_V1.potx")

PPPres.Slides(1).Shapes(1).TextFrame.TextRange.Text = "Company Profile: " & ThisWorkbook.Sheets(1).Cells(i, 1).Value
PPPres.Slides(1).Shapes(2).TextFrame.TextRange.Text = "By www.excelvbamacros.com"

' add data to first table of second slide
Set Shp = PPPres.Slides(2).Shapes("Table 1")
Shp.Table.Cell(1, 2).Shape.TextFrame.TextRange.Text = ThisWorkbook.Sheets(1).Cells(i, 1).Value
Shp.Table.Cell(2, 2).Shape.TextFrame.TextRange.Text = ThisWorkbook.Sheets(1).Cells(i, 2).Value
Shp.Table.Cell(3, 2).Shape.TextFrame.TextRange.Text = ThisWorkbook.Sheets(1).Cells(i, 3).Value
Shp.Table.Cell(4, 2).Shape.TextFrame.TextRange.Text = ThisWorkbook.Sheets(1).Cells(i, 4).Value
' add data to second table of second slide
Set Shp = PPPres.Slides(2).Shapes("Table 2")
Shp.Table.Cell(1, 2).Shape.TextFrame.TextRange.Text = ThisWorkbook.Sheets(1).Cells(i, 5).Value
Shp.Table.Cell(2, 2).Shape.TextFrame.TextRange.Text = ThisWorkbook.Sheets(1).Cells(i, 6).Value
Shp.Table.Cell(3, 2).Shape.TextFrame.TextRange.Text = ThisWorkbook.Sheets(1).Cells(i, 7).Value
Shp.Table.Cell(4, 2).Shape.TextFrame.TextRange.Text = ThisWorkbook.Sheets(1).Cells(i, 8).Value
' add data to first table of third slide
Set Shp = PPPres.Slides(2).Shapes("Table 5")
Shp.Table.Cell(1, 2).Shape.TextFrame.TextRange.Text = ThisWorkbook.Sheets(1).Cells(i, 9).Value
Shp.Table.Cell(2, 2).Shape.TextFrame.TextRange.Text = ThisWorkbook.Sheets(1).Cells(i, 10).Value
Shp.Table.Cell(3, 2).Shape.TextFrame.TextRange.Text = ThisWorkbook.Sheets(1).Cells(i, 11).Value
Shp.Table.Cell(4, 2).Shape.TextFrame.TextRange.Text = ThisWorkbook.Sheets(1).Cells(i, 12).Value

' save the ppt with the cell "a2" , "a3", etc value ( company names)
PPPres.SaveAs ThisWorkbook.Path & "\" & ThisWorkbook.Sheets(1).Cells(i, 1).Value & ".pptx"
PPPres.Close

Next
PPApp.Quit

Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing

End Sub


Download Working File