循环遍历 Excel 行，将它们复制并粘贴到单独的 Power Point 幻灯片中

Question

我正在尝试遍历 Excel 中的 3 行并将它们复制并粘贴到三个单独的幻灯片中。

此代码将复制所有 3 行并将所有 3 行粘贴到三个单独的幻灯片中。但是，我正在尝试复制幻灯片 1 中的第 1 行、幻灯片 2 中的第 2 行和幻灯片 3 中的第 3 行。有什么办法吗？

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

此代码将复制所有 3 行并将所有 3 行粘贴到三个单独的幻灯片中。我正在尝试复制幻灯片 1 中的第 1 行、幻灯片 2 中的第 2 行和幻灯片 3 中的第 3 行。有什么办法吗？

Answer 1

这样的东西应该可以工作（未经测试）

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 已更改以满足 OP 要求； 我已经测试了下面的代码，它将添加一个新的 pps，将每行中的每个范围复制到最后一行，然后粘贴到新的 pps.slide 中，然后循环。注意：我尽量保留您的代码。

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