Individual Cells to Individual Slides

Hello,

I'm a VBA newbie, so I've been toying all day with this. I have several excel workbooks with varying data ranges. In a given excel workbook I want to be able to copy the contents of each individual cell in the used range to a new powerpoint slide in the order of left to right and from row to row. The result will be that all cells within that worksheet's data range have been copied to their own powerpoint slide in a presentation that presents in the same sequential order as the copying took place.

For example, the copying happens like this:
A1 -> First slide
A2 -> Second slide
A3 -> Third slide

This is what I have piled together so far (see below), but it's not quite there yet. Could anyone help?

Thanks a lot,
ML

Sub Pleasework()

' 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)


' Find 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
Dim ppSlide As PowerPoint.slide

totalcells = lastrow * lastcol
Set rng = Range(Cells(1, 1), Cells(lastrow, lastcol))

For Each row In rng.Rows
For Each cell In row.Cells
cell.Select
Selection.copy
For x = 1 To totalcells
Set ppSlide = ppPres.Slides.Add(ppPres.Slides.Count + 1, ppLayoutText)
ppApp.ActivePresentation.Slides(x).Select
ppApp.ActiveWindow.Selection.SlideRange.Shapes("Rectangle 2").Select
ppApp.ActiveWindow.Selection.TextRange.Paste

Next cell
Next row
Next x

End Sub

I've found something that works, but unfortunately, the slides are all in reverse order. Any ideas?

Sub final()

' 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)


' Find 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
Dim ppSlide As PowerPoint.slide
Dim x As Integer

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

For Each row In rng.Rows
For Each cell In row.Cells
cell.Select
Selection.copy

Set ppSlide = ppPres.Slides.Add(1, ppLayoutText)
ppApp.ActivePresentation.Slides(1).Select
ppApp.ActiveWindow.Selection.SlideRange.Shapes("Rectangle 2").Select
ppApp.ActiveWindow.Selection.TextRange.Paste

Next cell
Next row

End Sub

I finally succeeded in making it run in order. However, it always stops after 248 pastes exactly. What does that mean?

Solved by myself:

I think this is a limitation of PowerPoint.