Pasting a large table into separate slides by Excel VBA - excel

Question

I would like to paste a table from excel to power point using VBA. However, as I have dynamic range therefore I would like to create slides with 15 rows only for better visualization. For example, it will paste row 1 to row 15 into slide number 1 then row 1, and row 16 to row 29 into slide number 2 and so on. Here row 1 is the header of the table. I have attached the code where I can create only one slide. I would highly appreciate if anyone can help me.
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

Remove your current definition of LastRow. Then delete everything after your Set slds = myPres.Slides line and paste this code instead.
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