Циклическое копирование строк Excel с копированием и вставкой в ​​отдельные слайды Power Point - PullRequest
Новая
       29

Циклическое копирование строк Excel с копированием и вставкой в ​​отдельные слайды Power Point

0 голосов
/ 26 марта 2019

Я пытаюсь перебрать 3 строки в Excel, скопировать их и вставить их в три отдельных слайда Power Point.

Этот код скопирует ВСЕ 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. Есть ли способ сделать это?

1 Ответ

0 голосов
/ 26 марта 2019

Примерно так должно работать (не проверено) 

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
...