Convert XLS database into PPT Slides, 1 row = 1 Slide

Option Explicit

' Set to true for IntelliSense and add a reference to Microsoft PowerPoint XX Object Library.
' Delete reference and set to false for production.
#Const DEV_MODE = False

' ==============================================
' Macro to export rows of data from a worksheet to text boxes in PowerPoint (runs from Excel)
' One slide per row, one text box per column
' Dependencies : none
' Tested : Excel and PowerPoint 2016 (PC)
' Source : http://youpresent.co.uk/
' Author : Jamie Garroch
' Date : 19 October 2018
' ==============================================
Sub ExportChartsToPowerPoint()
    ' Declarations for Excel objects
    Dim oWB As Workbook
    Dim oWS As Worksheet
    Dim oRng As Range
    Dim oCell As Excel.Range
    ' Declarations for PowerPoint late-binding objects
#If DEV_MODE Then
    Dim oPPT As PowerPoint.Application
    Dim oPres As PowerPoint.Presentation
    Dim oSld As PowerPoint.Slide
    Dim oShp As PowerPoint.Shape
#Else
    Dim oPPT As Object  ' PowerPoint Application
    Dim oPres As Object ' Presentation
    Dim oSld As Object  ' Slide
    Dim oShp As Object  ' Shape
#End If
  
    ' Module variables
    Dim lRow As Long, lCol As Long
    Dim sShpLeft As Single, sShpTop As Single
    
    ' Constants (change as necessary)
    Const OFFSET_X = 50 ' Offset from the left of the slide
    Const OFFSET_y = 50 ' Offset from the top of the slide
    Const SPACING_X = 50 ' Horizontal space between text boxes
    Const SPACING_y = 50 ' Vertical space between text boxes
    Const TEXTBOX_WIDTH = 100 ' Width of the textboxes
    
    Set oWB = ActiveWorkbook
    ' The next line assumes we are just using sheet 1
    Set oWS = oWB.Worksheets(1)
    ' This line is an alternative to the above and uses the active sheet:
    'Set oWS = oWB.ActiveSheet
    
    ' Try to get an existing instance of PowerPoint application
    Set oPPT = GetObject(, "PowerPoint.Application")
    ' If none exists, create one
    If Err Then Set oPPT = CreateObject("PowerPoint.Application")
    If Err Then MsgBox "Couldn't start PowerPoint.", vbCritical + vbOKOnly, "No PowerPoint": Exit Sub
    
    ' Create a new presentation using the default template set on the system (blank.potx)
    Set oPres = oPPT.Presentations.Add(msoTrue)
    
    ' Set a reference to the used range of cells in the sheet
    Set oRng = oWS.UsedRange
    
    For lRow = 1 To oRng.Rows.Count
      ' Add a new slide to the PowerPoint presentation. Change the CustomLayouts index according to the required layout ID.
      Set oSld = oPres.Slides.AddSlide(oPres.Slides.Count + 1, oPres.SlideMaster.CustomLayouts(1))
      For lCol = 1 To oRng.Columns.Count
        Set oCell = oWS.Cells(lRow, lCol)
        sShpLeft = OFFSET_X + ((lCol - 1) * (SPACING_X + TEXTBOX_WIDTH))
        sShpTop = OFFSET_y
        Set oShp = oSld.Shapes.AddTextbox(msoTextOrientationHorizontal, sShpLeft, sShpTop, TEXTBOX_WIDTH, 0)
        With oShp
          .Line.Visible = msoTrue ' set this to false to hide the text box outline
          With .TextFrame2
            .WordWrap = msoTrue
            .AutoSize = msoAutoSizeShapeToFitText
            '.TextRange = oRng.Cells(lRow, lCol).Shape.TextFrame2.TextRange
            With .TextRange
              .Text = oCell.Value
              With .Font
                .Name = oCell.Font.Name
                .Size = oCell.Font.Size
              End With
            End With
          End With
        End With
      Next
    Next
    
    ' Clear Excel Objects
    Set oWB = Nothing: Set oWS = Nothing: Set oRng = Nothing: Set oCell = Nothing
    ' Clear PowerPoint objects
    Set oPPT = Nothing: Set oPres = Nothing: Set oSld = Nothing: Set oShp = Nothing
End Sub

Select all Open in new window