Looping through Excel rows copying and pasting them in SEPARATE Power Point Slides

Question

I'm trying to loop through 3 rows in Excel and copy them and paste them into three separate power point slides.

This code will copy ALL 3 rows and paste ALL 3 rows in three separate slides. HOWEVER, I'm trying to copy row 1 in slide 1, row 2 in slide 2 and row 3 in slide 3. Is there any way to do this?

Sub Copy_Paste_ExcelPPT()
Dim PPTApp As Powerpoint.Application
Dim PPTPres As PowerPoint.Presentation
Dim PPTSlide As PowerPoint.Slide
Dim rng As Range
Dim row As Range
Dim cell As Range
Dim rngarray As Variant
Dim ExcRng As Range
'Create new instance of PowerPoint
Set PPTApp=New PowerPoint.Application
PPTApp. Visible=True 
'Create a new presentation
Set PPTPres=PPTApp.Presentations.Add
'Loop through each row in the excel file
Set rng =Range("F4:H6")
For Each row In rng.Rows
    For Each row In row.Cells
        'Create an array that houses references to the ranges we want to export
        rngarray= Array(rng)
        'Loop through this array, copy the row, create a new slide and paste the row in a different slide 
        For x=LBound(rngarray) To UBound(rngarray)
            Set a reference to the range we want to export
            Set ExcRng=rngarray(x)
            'Copy the range
            ExcRng.Copy
            'Create a new slide in the presentation
            Set PPTSlide=PPTPres.Slides.Add(x+1,ppLayoutBlank)
            'Paste the range in the slide
            PPTSlide.Shapes.Paste
        Next x
    Next cell
Next row
End Sub

This code will copy ALL 3 rows and paste ALL 3 rows in three separate slides. I'm trying to copy row 1 in slide 1, row 2 in slide 2 and row 3 in slide 3. Is there any way to do this?

Answer 1

Something like this should work (not tested)

Set rng1 = ThisWorkbook.Worksheets("Name").Range("F4:H4") 'change "Name" to Sheet name
Set rng2 = ThisWorkbook.Worksheets("Name").Range("F5:H5")
Set rng3 = ThisWorkbook.Worksheets("Name").Range("F6:H6")

rngarray = Array(rng1, rng2, rng3)

For x=LBound(rngarray) To UBound(rngarray)

EDIT changed to meet OP requirements; I've tested the below code and it will add a new pps, copy each range in each row until the last row, then paste into a new pps.slide, and loop. Note: I tried to keep as much of your code as possible.

Dim ppTApp As PowerPoint.Application
Dim ppTPres As PowerPoint.Presentation
Dim ppTSlide As PowerPoint.Slide

Set ppTApp = New PowerPoint.Application
ppTApp.Visible = True

Set ppTPres = ppTApp.Presentations.Add

Dim ws As Worksheet, lRow As Long
Set ws = ThisWorkbook.Sheets("Sheet1") 'Change to meet your needs
lRow = ws.Cells(Rows.Count, 6).End(xlUp).Row

For x = 4 To lRow

    ws.Cells(x, 6).Resize(, 3).Copy

    Set ppTSlide = ppTPres.Slides.Add(ppTPres.Slides.Count + 1, ppLayoutBlank)
    ppTSlide.Shapes.Paste

Next x