Convert Excel cells into PPT Slide Textboxes

I have a 9 ideas spread over three tabs of an Excel spreadsheet, three rows each. Please see attached Excel file example.
I would like to convert them into a single slide PPT, please see attached PPT file example.

How could I convert the source Excel file into the destination PPT slide with minimal manual work?Source.xlsx
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Jamie GarrochSenior Technical Consultant at BrightCarbonCommented:
This is tested and working with the Excel file you provided:

Option Explicit

' Change to true to use IntelliSense and add a reference to the Microsoft PowerPoint XX Object Library
' Change to false for production and remove the reference to the Microsoft PowerPoint XX Object Library
#Const DEV_MODE = False

' ===========================================================================
' Macro to create a presentation from the data in 3 sheets of an Excel file
' Target : Excel VBE
' Author : Jamie Garroch of
' Date : 28NOV2018
' ===========================================================================
Sub CreatePresentation()
  ' Early bound PowerPoint objects (requires reference to PowerPoint library)
  Dim oPPT As PowerPoint.Application
  Dim oPres As PowerPoint.Presentation
  Dim oSld As PowerPoint.slide
  Dim oShp As PowerPoint.Shape
  ' Late bound PowerPoint objects (no reference required)
  Dim oPPT As Object
  Dim oPres As Object
  Dim oSld As Object
  Dim oShp As Object
#End If
  ' Excel objects
  Dim oWS As Worksheet
  ' PowerPoint textbox layout variables
  Dim lRow As Long
  Dim lCol As Long
  ' PowerPoint textbox layout constants
  Const ShpWidth = 135.9184
  Const ShpHeight = 80.08165
  Const xOffset = 238.7755
  Const yOffset = 114.6122
  Const xSpacing = 19.10205
  Const ySpacing = 35.26527
  On Error Resume Next
  ' Use an existing instance of PowerPoint, if it exists
  Set oPPT = GetObject(, "PowerPoint.Application")
  ' If PowerPoint isn't running, start it
  If Err Then
    Set oPPT = CreateObject("PowerPoint.Application")
    If Err Then MsgBox "Couldn't start PowerPoint.", vbCritical + vbOKOnly, "PowerPoint Error": Exit Sub
  End If
  ' Create a new presentation (using the default template set on the user's machine e.g. blank.potx)
  Set oPres = oPPT.Presentations.Add
  ' Change the "1" in "CustomLayouts(7)" to the index of the slide layout you need in your PowerPoint template
  ' 7 = Blank layout in Destination.pptx
  Set oSld = oPres.Slides.AddSlide(1, oPres.SlideMaster.CustomLayouts(7))
  ' Create the 9 textbox shapes, referring to the data in the sheets as follows:
  ' SheetX = RowX, ColY = SheetX/RowY+1
  With oSld.Shapes
    For lRow = 1 To 3
      Set oWS = ActiveWorkbook.Worksheets(lRow)
      For lCol = 1 To 3
        Set oShp = oSld.Shapes.AddShape(msoShapeRectangle, xOffset + (lCol - 1) * (ShpWidth + xSpacing), yOffset + (lRow - 1) * (ShpHeight + ySpacing), ShpWidth, ShpHeight)
        With oShp.TextFrame.TextRange
          ' Copy the text from Excel to the text box and format it as required
          .Text = oWS.Cells(lCol + 1, 1) & vbCrLf & oWS.Cells(lCol + 1, 2)
          .Font.Size = 8
          ' Format the text box title text
          With .Paragraphs(1).Font
            .Size = 18
            .Bold = msoTrue
          End With
        End With
  End With

End Sub

Open in new window

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Sam JacobsDirector of Technology Development, IPMCommented:
Member_2_7966563Author Commented:
Thanks Jamie, your solution worked straight out of the box
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today

From novice to tech pro — start learning today.