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)

编辑已更改为符合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

遍历Excel行将其复制并粘贴到单独的Power Point幻灯片中

1 个答案: