To Powerpoint


FDim PAplication As PowerPoint.Application
Dim Sld As PowerPoint.Slide

Dim DataRange As Range
Dim DataRow As Range
Dim DataColumn As Range

Dim oShape As PowerPoint.Shape
Dim oPicture As PowerPoint.Shape

Set PAplication = New PowerPoint.Application

PAplication.Visible = msoCTrue
PAplication.WindowState = ppWindowMaximized

Set DataRange = ThisWorkbook.Sheets(1).Range("A1:B5") 'change this cell range for your own data range

For Each DataRow In DataRange.Rows

Set Sld = PAplication.ActivePresentation.Slides.AddSlide(PAplication.ActivePresentation.Slides.Count + 1, PAplication.ActivePresentation.SlideMaster.CustomLayouts(1))
'Add textbox from column B
Sld.Shapes(1).TextFrame.TextRange.Text = DataRow.Cells(1, 2)
Sld.Shapes(1).TextFrame.AutoSize = ppAutoSizeShapeToFitText
Sld.Shapes(1).Top = 0

'Add picture from column A
Set oShape = Sld.Shapes.AddPicture(DataRow.Cells(1, 1).Value, msoFalse, msoTrue, 1, 1, -1, -1) '(Filename, LinkToFile, SaveWithDocument, Left, Top, Width, Height)

'Size Picture, change this as your own preferences
Set oPicture = Sld.Shapes(Sld.Shapes.Count)
oPicture.ScaleHeight 1, msoTrue
oPicture.ScaleWidth 1, msoTrue
oPicture.LockAspectRatio = True
oPicture.Width = 300 '300 is arbitrary

'Center picture, change this as your own preferences
With PAplication.ActivePresentation.PageSetup
oPicture.Left = (.SlideWidth \ 2) - (oPicture.Width \ 2)
oPicture.Top = (.SlideHeight \ 2) - (oPicture.Height \ 2)
End With