How to get large Excel table to paste into multiple slides using vba?

Question

I am new to this forum, and new to VBA. I am working with a very large Excel table (200+ rows) where I have added a code in to identify page breaks based on when a value changes in one of the columns. I've figured out how to paste my range of data into a PowerPoint slide, but I need it to paste onto separate slides according to where/when the page break is set.

Here is my page break code:

J = ActiveSheet.Cells(Rows.Count, "I").End(xlUp).Row
For I = J To 2 Step -1
    If Range("I" & I).Value <> Range("I" & I - 1).Value Then
        ActiveSheet.HPageBreaks.Add Before:=Range("I" & I)
    End If
Next I

And here is what I have so far to get range into PowerPoint, but this pastes everything on one slide:

Dim rng As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object

'Copy Range from Excel
Set rng = ThisWorkbook.ActiveSheet.Range("A1:J5")

'Create an Instance of PowerPoint
  On Error Resume Next

'Is PowerPoint already opened?
  Set PowerPointApp = GetObject(class:="PowerPoint.Application")

'Clear the error between errors
  Err.Clear

'If PowerPoint is not already open then open PowerPoint
  If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")

'Handle if the PowerPoint Application is not found
  If Err.Number = 429 Then
    MsgBox "PowerPoint could not be found, aborting."
    Exit Sub
  End If

  On Error GoTo 0

'Optimize Code
  Application.ScreenUpdating = False

'Create a New Presentation
  Set myPresentation = PowerPointApp.Presentations.Add

'Add a slide to the Presentation
  Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly

'Copy Excel Range
  rng.Copy

'Paste to PowerPoint and position
  mySlide.Shapes.PasteSpecial DataType:=2  '2 = ppPasteEnhancedMetafile



Set shp = PowerPointApp.ActiveWindow.Selection.ShapeRange

'Center Object
  With myPresentation.PageSetup
    shp.Left = (.SlideWidth \ 2) - (shp.Width \ 2)
    shp.Top = (.SlideHeight \ 2) - (shp.Height \ 2)


'Make PowerPoint Visible and Active
  PowerPointApp.Visible = True
  PowerPointApp.Activate

'Clear The Clipboard
  Application.CutCopyMode = False

  End With

Answer 1

You can use this VBA code, takes every 15 row (as page) to paste into new slide.

Private Sub Multipage_Slide()

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") 
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


    Set pptextbox = sld.Shapes.AddTextbox(msoTextOrientationHorizontal, 22, 60, 700, 60)

    With pptextbox.TextFrame
        .TextRange.Text = "Multiple Slides"  
        .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

N.B.

• A1:L1 is Header, you may adjust it.
• Last Row value Application.Min(i + 13, LastRow), can be adjusted (currently picks 15 Row).
• Font name, color & size also are editable.