How to copy every 15 rows within excel range into separate PowerPoint slides

Question

I currently have a larger table in excel that I am trying to copy/paste into an existing PPT doc. Since the table is too long to fit on one slide I'm trying to have it take every 15 rows and paste on a new slide. The code below works, but it is set up to take a specified range for each slide. I've tried several other ways, but they all end up opening the PPT doc and essentially doing nothing.

  Sub ExcelToPowerPoint()
  Dim PPapp As PowerPoint.Application
  Dim PPpres As PowerPoint.Presentation
  Dim PPslide As PowerPoint.Slide
  Dim Xlws As Worksheet
  Dim rng As Range 

  Dim myPresentation As Object
  Dim mySlide As Object
  Dim PowerPointApp As Object
  Dim MySlideArray As Variant
  Dim MyRangeArray As Variant

  Dim x As Long      
  Dim shp As Object

  Dim i As Long
  Dim j As Integer

  Set Xlws = ActiveSheet
  Set PPapp = New PowerPoint.Application
  Set PPpres = PPapp.Presentations.Open("insert name of doc here")

  PPapp.ActivePresentation.Slides(4).Select
  PPapp.Activate
  PPapp.Visible = True

  'List of PPT Slides to Paste to
  MySlideArray = Array(4, 5, 6)

  'List of Excel Ranges to Copy from
  MyRangeArray = Array(Sheets("Template").Range("B1:K16"), Sheets("Template").Range("B16:K31"), Sheets("Template").Range("B31:K45"))

  'Loop through Array data
  For x = LBound(MySlideArray) To UBound(MySlideArray)

  'Copy Excel Range
  MyRangeArray(x).Copy

  On Error Resume Next

  Set shp = PPpres.Slides(MySlideArray(x)).Shapes.PasteSpecial(ppPasteEnhancedMetafile)
  shp.Shapes.PasteSpecial ppPasteEnhancedMetafile
  Set mySlide = PPapp.ActiveWindow.Selection.ShapeRange

  mySlide.Left = 30     
  mySlide.Top = 85
  mySlide.Height = 150
  mySlide.Width = 900

  Next x

  End Sub

If it works and its doing what you want, I am failing to see what the problem is. Are you asking how to make MyRangeArray dynamic and accept a range with any number of rows? — Toddleson, Apr 28 '21 at 20:11

score 0 · Answer 1 · answered Apr 28 '21 at 21:58

I think this is what you want.

Option Explicit

Sub Test()

    Dim lastrow As Long
    Dim row1 As Long
    Dim row2 As Long
    Dim dataRange As Range
    
    With Sheets("Template")
    
        ' Get last row on sheet 
        lastrow = .Cells.Find("*", SearchOrder:=xlByRows, searchdirection:=xlPrevious).row

        ' Copy data 15 rows at a time            
        row1 = 1

        Do While row1 < lastrow
        
            row2 = row1 + 14
            If row2 > lastrow Then
                row2 = lastrow
            End If
            
            ' Copy data range
            .Range("B" & row1 & ":K" & row2).Copy
            
            '*********************************
            '* Paste data to PowerPoint here *
            '*********************************
            
            row1 = row2 + 1
            
        Loop
        
    End With
    

End Sub

P.S. You might want to read this How to avoid using Select in Excel VBA

How to copy every 15 rows within excel range into separate PowerPoint slides

1 Answers1