This may seem like a really weird thing to want to do. Imagine this though: You want a presentation to show off the names of a lot of students on a constant loop at a kiosk, and you don’t want to have to retype the names. VBA to the rescue.
This little snippet of code will do the following:
- Open a given Excel Document
- For Each used row in column A of sheet 1, create a copy the first slide in the presentation.
- Change the text of the first text box to the content of that cell
Easy. Here it is:
Sub CreateSlides() 'Open the Excel workbook. Change the filename here. Dim OWB As New Excel.Workbook Set OWB = Excel.Application.Workbooks.Open("C:\list.xlsx") 'Grab the first Worksheet in the Workbook Dim WS As Excel.Worksheet Set WS = OWB.Worksheets(1) 'Loop through each used row in Column A For i = 1 To WS.Range("A65536").End(xlUp).Row 'Copy the first slide and paste at the end of the presentation ActivePresentation.Slides(1).Copy ActivePresentation.Slides.Paste (ActivePresentation.Slides.Count + 1) 'Change the text of the first text box on the slide. ActivePresentation.Slides(ActivePresentation.Slides.Count).Shapes(1).TextFrame.TextRange.Text = WS.Cells(i, 1).Value Next End Sub
Paste this into a new module inside your PowerPoint presentation. You will need to add in a reference to Microsoft Excel Objects (Tools -> References). Change the name and location of the Excel file that you want to use.
If you set up the first slide exactly as you want it before running the macro, then the same formats and layout will be copied too. Alternatively use Slide Masters to set up all the slides after they have been created.
Extension – by request
This edit below looks at each row and determines the number of used columns in that row. For each row, a text box is populated on the slide with all of the values in that row, with a carriage return between each value.
Sub CreateSlides() 'Open the Excel workbook. Change the filename here. Dim OWB As New Excel.Workbook Set OWB = Excel.Application.Workbooks.Open("C:\list.xlsx") 'Grab the first Worksheet in the Workbook Dim WS As Excel.Worksheet Set WS = OWB.Worksheets(1) Dim str As String 'Loop through each used row in Column A For i = 1 To WS.Range("A65536").End(xlup).Row 'Copy the first slide and paste at the end of the presentation ActivePresentation.Slides(1).Copy ActivePresentation.Slides.Paste (ActivePresentation.Slides.Count + 1) 'Get the number of columns in use on the current row Dim LastCol As Long LastCol = WS.Rows(i).End(xlToRight).Column If LastCol = 16384 Then LastCol = 1 'For some reason if only column 1 has data it returns 16384, so correct it 'Build a string of all the columns on the row str = "" For j = 1 To LastCol If j <> 1 Then str = str & Chr(13) str = str & WS.Cells(i, j).Value Next 'Write the string to the slide ActivePresentation.Slides(ActivePresentation.Slides.Count).Shapes(1).TextFrame.TextRange.Text = str Next End Sub
Reversing the Process – Export Slides to Excel
Again, by request we have the reverse of this process. This routine takes a PowerPoint presentation, and exports any objects that have a text value to an Excel workbook. Each slide is on a different row, and each shape is given a different column. Run from PowerPoint, adding in the Microsoft Excel Objects as before.
Sub CreateWorkbookFromSlides() On Error Resume Next ' Create the Excel Workbook Object Dim OWB As Excel.Workbook Set OWB = Workbooks.Add Dim CurXLRow As Integer Dim CurXLCol As Integer CurXLRow = 1 ' Go through each of the slides in the presentation, extracting text for each object For i = 1 To ActivePresentation.Slides.Count CurXLCol = 1 For j = 1 To ActivePresentation.Slides(i).Shapes.Count If ActivePresentation.Slides(i).Shapes(j).HasTextFrame = msoTrue Then OWB.Worksheets(1).Cells(CurXLRow, CurXLCol).Value = ActivePresentation.Slides(i).Shapes(j).TextFrame.TextRange.Text CurXLCol = CurXLCol + 1 End If Next CurXLRow = CurXLRow + 1 Next 'Prompt for the filename to save as and capture any errors strFileName = InputBox("Enter the full path to save the file as (e.g C:\MyExtract.xlsx:", "Creating New File...") If strFileName <> "" Then OWB.SaveAs strFileName Else MsgBox ("Invalid filename. Excel Export not saved") End If If Err.Number <> 0 Then MsgBox ("There was an error saving the file.") End If 'Close off the workbook when we are finished OWB.Close End Sub
Listing Shapes on the First Slide
One of the main issues with this script is identifying the shapes on the slides. The section of VBA code below will show a message box for each shape on the first slide which details the shape ID, the name of the shape and the type of the shape. The shape ID can then be inserted into the code above:
You will need both the ListShapes sub and the ShapeType function. Run the ListShapes macro, and each shape will be listed.
Sub ListShapes() If ActivePresentation.Slides(1).Shapes.Count = 0 Then MsgBox "No shapes on slide 1?" Else For i = 1 To ActivePresentation.Slides(1).Shapes.Count MsgBox "Shape Number " & i & Chr(13) & _ "Shape Name: " & ActivePresentation.Slides(1).Shapes(i).Name & Chr(13) & _ "Shape Type: " & ShapeType(ActivePresentation.Slides(1).Shapes(i).Type) Next End If End Sub Function ShapeType(ShapeTypeInt) Select Case ShapeTypeInt Case 1: ShapeType = "Autoshape" Case 2: ShapeType = "Callout" Case 3: ShapeType = "Chart" Case 4: ShapeType = "Comment" Case 5: ShapeType = "Freeform" Case 6: ShapeType = "Group" Case 7: ShapeType = "Embedded OLE Object" Case 8: ShapeType = "Form Control" Case 9: ShapeType = "Line" Case 10: ShapeType = "Linked OLE Object" Case 11: ShapeType = "Linked Picture" Case 12: ShapeType = "OLE Control Object" Case 13: ShapeType = "Picture" Case 14: ShapeType = "Placeholder (for titles, etc)" Case 15: ShapeType = "WordArt" Case 16: ShapeType = "Media" Case 17: ShapeType = "Text Box" Case 18: ShapeType = "Script Anchor" Case 19: ShapeType = "Table" Case 20: ShapeType = "Canvas" Case 21: ShapeType = "Diagram" Case 22: ShapeType = "Ink" Case 23: ShapeType = "Ink Comment" Case -2: ShapeType = "Mixed Type Shape" Case Else: ShapeType = "Unknown Shape Type" End Select End Function