Excel Cells to PPT Cells- Two Variable Ranges

Hi all,

I've attempted to write a macro that copies individual cells from Excel sheets to individual cells in tables that I have set up in PowerPoint:

1. For each second row of data in Excel, the macro creates a slide with an empty PowerPoint table in PowerPoint. (The originally empty PowerPoint tables on all slides are identical.)
2. Then it is supposed to put the data from each cell in each of those second Excel rows into the proper cell of the table on each PowerPoint slide. So, the 1st row cells are populated into the designated cells of the 1st slide, the 3rd row cells are populated into the designated cells of the 2nd slide, and so on...

I'm not sure of all the VBA options, but I've been attempting to do this primarily with For Next Loops:

- I successfully created a For Next Loop for Step 1 above. A slide has been created for each second row of data in my Excel sheet.
- However step two has two loop ranges: it must loop through each slide in the PowerPoint presentation, and at the same time it must loop through every second row of data in the Excel sheet-- because the macro populates the slides with the data of each second row of the Excel sheet. You see?

I see an option of successive or nested loops, but no option of two value ranges looping at the same time. Perhaps I shouldn't be using For Next Loops?

Sub celltocell()

Dim ppApp As PowerPoint.Application
Set ppApp = New PowerPoint.Application

Dim file As String
file = "C:\Users\ML\Desktop\Presentation1.pptx"

Dim ppPres As PowerPoint.Presentation
Set ppPres = ppApp.Presentations.Open(file)

ppApp.Visible = True
ppApp.ActiveWindow.ViewType = ppViewSlide

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 x As Integer
Dim q As Integer
q = lastrow / 2

For x = 1 To (q - 1)
ppApp.ActivePresentation.Slides(1).Duplicate
Next x

Dim y As Integer
Dim b As Integer

For y = 1 To (lastrow - 2) Step 2
For b = 1 To (q - 1)
Dim col1 As String
col1 = Cells(y, 1)

ppApp.ActivePresentation.Slides(b).Select
ppApp.ActiveWindow.Selection.SlideRange.Shapes("Table 1").Table.cell(1, 1).Shape.TextFrame.TextRange.Select
ppApp.ActiveWindow.Selection.TextRange.Text = col1

Dim col2 As String
col2 = Cells(y, 2)

ppApp.ActivePresentation.Slides(b).Select
ppApp.ActiveWindow.Selection.SlideRange.Shapes("Table 1").Table.cell(2, 1).Shape.TextFrame.TextRange.Select
ppApp.ActiveWindow.Selection.TextRange.Text = col2

Dim col3 As String
col3 = Cells(y, 3)

ppApp.ActivePresentation.Slides(b).Select
ppApp.ActiveWindow.Selection.SlideRange.Shapes("Table 1").Table.cell(3, 1).Shape.TextFrame.TextRange.Select
ppApp.ActiveWindow.Selection.TextRange.Text = col3

Dim col4 As String
col4 = Cells(y, 4)

ppApp.ActivePresentation.Slides(b).Select
ppApp.ActiveWindow.Selection.SlideRange.Shapes("Table 1").Table.cell(4, 1).Shape.TextFrame.TextRange.Select
ppApp.ActiveWindow.Selection.TextRange.Text = col4

Next b
Next y


End Sub

As you can see I'm having trouble finding a way to loop through b and y simultaneously, so that the 1st row of data goes on the first slide, the 3rd row of data goes on the second slide, the 5th row of data goes on the 3rd slide, etc.

If the thread title does not correctly describe the contents, please suggest how to rephrase it.

Thank you,

ML