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