Вставка большого стола в отдельные слайды с помощью Excel VBA

Question

Я бы хотел вставить таблицу из Excel в Power Point, используя VBA. Однако, поскольку у меня есть динамический диапазон, поэтому я хотел бы создавать слайды с 15 строками только для лучшей визуализации. Например, строка 1 - строка 15 будет вставлена ​​в слайд № 1, затем строка 1, а строка 16 - строка 29 в слайд № 2 и т. Д. Здесь строка 1 является заголовком таблицы. Я приложил код, где я могу создать только один слайд. Буду очень признателен, если кто-нибудь сможет мне помочь.

Sub SortingandSlidecreation()

    Dim pptName As String
    Dim ppt As PowerPoint.Application
    Dim myPres As PowerPoint.Presentation
    Dim slds As PowerPoint.Slides
    Dim sld As PowerPoint.slide
    Dim pptextbox As PowerPoint.Shape
    Dim oLayout As CustomLayout
    Dim wb As Workbook
    Dim ws As Worksheet

    Dim y As Workbook, LastRow&
    Dim r As Range


    Set wb = ThisWorkbook
    Set ws = wb.Sheets("SortedTable")

    'This will open a PowerPoint template (I didn't attach the function) 
    pptName = openDialog()                                              
    Set ppt = CreateObject("PowerPoint.Application")
    Set myPres = ppt.Presentations.Open(pptName)
    Set slds = myPres.Slides

    ' creating slides at the end of the template 
    Set sld = slds.Add(myPres.Slides.Count + 1, ppLayoutBlank)

    'Here data is selected for pasting
    Set r = ThisWorkbook.Worksheets("SortedTable").Range("A1:L" & LastRow)
    r.Copy
    sld.Shapes.PasteSpecial DataType:=0
    sld.Shapes(1).Top = 100
    sld.Shapes(1).Left = 100

    'Here title of the table is added
    Set pptextbox = sld.Shapes.AddTextbox(msoTextOrientationHorizontal, 22, 60, 700, 60)

    With pptextbox.TextFrame
        .TextRange.Text = "Summary of Current Projects"  
        .TextRange.Font.Bold = msoTrue
        .TextRange.Font.Name = "Arial(Headings)"
        .TextRange.Font.Size = 20
        .TextRange.Font.Color.RGB = RGB(0, 51, 102)
    End With

End Sub

Answer 1

Удалите текущее определение LastRow.Затем удалите все после строки Set slds = myPres.Slides и вставьте этот код.

Dim LastRow as Long, i as Long, j as Integer, rngH as Range, wss as Worksheet
LastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Set rngH = ws.Range("A1:L1") 'Header Row
i = 2
Set wss = wb.Worksheets.Add

Do While i <= LastRow
    j = Application.Min(i + 13, LastRow)
    Union(rngH, ws.Range("A" & i, ws.Range("L" & j))).Copy Destination:= wss.Range("A1")
    Set sld = slds.Add(myPres.Slides.Count + 1, ppLayoutBlank)
    wss.Range("A1:L" & j-i+2).Copy
    sld.Shapes.PasteSpecial DataType:=0
    sld.Shapes(1).Top = 100
    sld.Shapes(1).Left = 100

    'Here title of the table is added
    Set pptextbox = sld.Shapes.AddTextbox(msoTextOrientationHorizontal, 22, 60, 700, 60)

    With pptextbox.TextFrame
        .TextRange.Text = "Summary of Current Projects"  
        .TextRange.Font.Bold = msoTrue
        .TextRange.Font.Name = "Arial(Headings)"
        .TextRange.Font.Size = 20
        .TextRange.Font.Color.RGB = RGB(0, 51, 102)
    End With
    i = j + 1
Loop

Application.DisplayAlerts = False
wss.Delete
Application.DisplayAlerts = True
Set wss = Nothing
End Sub