Create Data Slides in PowerPoint from Excel using VBA

[J_R]

Hi,


Rather than creating 100+ slides from scratch, I want to do a mail merge into PowerPoint, and need some help cleaning up the macro I managed to piece together (from various forums on the net). I don't want to use the code to populate tables or charts, but to set up the titles and body text from my spreadsheet.


Excel Data (in a very simplistic form) is:


A B C

1 Slide No. Slide Title Ref

2 1 Slide 1 Text

3 2 Slide 2 Text

etc down to Slide 105


I am not a developer, but I've managed to put together this macro that works, just not to my exact liking. It creates a slide for each cell, so I want to fine tune it so that each slide is for each row. So far I am fine if it's just Column B as my slide title, as I may or may not use Column C as a placeholder, but want to know for future ref.


Column B maps to Shapes(1); column C maps to Shapes(2), etc.


-----------------------

Sub CreateSlides()


' Start PowerPoint.

Dim ppApp As PowerPoint.Application

Set ppApp = CreateObject("Powerpoint.Application")


' Make it visible.

ppApp.Visible = True


' Add a new presentation.

Dim ppPres As PowerPoint.Presentation

Set ppPres = ppApp.Presentations.Add(msoTrue)


' Add new slide.

Dim ppSlide As PowerPoint.Slide

Set ppSlide = ppPres.Slides.Add(Index:=1, Layout:=ppLayoutText)


' Find coordinates of last cell in range.

Dim lastrow As Integer

Dim lastcol As Integer

lastrow = Cells.Find(What:="*", After:=[A1], SearchDirection:=xlPrevious).row

lastcol = Cells.Find(What:="*", After:=[A1], SearchDirection:=xlPrevious).Column


Dim rng As Range

Dim row As Range

Dim cell As Range


Set rng = Range(Cells(2, 2), Cells(lastrow, lastcol))


For Each row In rng.Rows

For Each cell In row.Cells

cell.Select

Selection.Copy


Dim ppSlide2 As PowerPoint.Slide

Dim x As Integer

x = ppPres.Slides.Count

Set ppSlide2 = ppPres.Slides.Add(Index:=x, Layout:=ppLayoutText)

ppApp.ActivePresentation.Slides(x).Select

ppApp.ActiveWindow.Selection.SlideRange.Shapes(1).Select

ppApp.ActiveWindow.Selection.TextRange.Paste


Next cell

Next row


End Sub


-----------------------


Can anyone please help? I appreciate you being specific.


I'm happy to format font and size of text in my slide master, but if that is an easy tag to incorporate, please advise.


Thanks in advance!

 

[NARAYANK991]

Hi ,


Can you try this ?

[pre]

Sub CreateSlides()

'   Start PowerPoint.
Dim ppApp As PowerPoint.Application
Set ppApp = CreateObject("Powerpoint.Application")

'   Make it visible.
ppApp.Visible = True

'   Add a new presentation.
Dim ppPres As PowerPoint.Presentation
Set ppPres = ppApp.Presentations.Add(msoTrue)

'   Add new slide.
Dim ppSlide As PowerPoint.Slide
Set ppSlide = ppPres.Slides.Add(Index:=1, Layout:=ppLayoutText)

'   Find coordinates of last cell in range.
Dim x As Integer
x = 1
Dim lastrow As Integer
Dim lastcol As Integer
lastrow = Cells.Find(What:="*", After:=[A1], SearchDirection:=xlPrevious).row
lastcol = Cells.Find(What:="*", After:=[A1], SearchDirection:=xlPrevious).Column

Dim rng As Range
Dim row As Range
Dim cell As Range

Set rng = Range(Cells(2, 2), Cells(lastrow, 2))

For Each cell In rng
Set ppSlide = ppPres.Slides.Add(Index:=x, Layout:=ppLayoutText)
ppSlide.Shapes(1).TextFrame.TextRange.Text = cell.Value
ppSlide.Shapes(2).TextFrame.TextRange.Text = cell.Offset(, 1).Value
x = x + 1
Next cell

End Sub

[/pre]
Note that I have not made use of lastcol ; I have assumed that you are using only columns B and C ; in case you have more columns and you wish to do so , you will have to introduce a second FOR ... NEXT loop inside the existing one.


Narayan