Error :Macro to Copy from Excel Worksheets and paste to specific Powerpoint slides

• Switches to Powerpoint or creates a new instance if Powerpoint is not running
• Opens your presentation
• Copies the slide format from the first slide
• Calculates the size available on each slide in which to paste an image from Excel - the code assumes that slide #4 contains a header box and a text area. The maximum size and image position are calculated from this text area (shape #2 on the slide). If your slides do not have these areas, the code will need tweaking.
• Loops throught each worksheet, chopping the "usedRange" into chunks that will fit on your powerpoint slides
• Loops through the chunks, copying them and pasting each chunk to a new slide
• Labels each slide based on source worksheet and chunk number
• Creates additional slides as needed, using the slide format copied from the first slide (you can change this, of course)

Option Explicit
Dim PP As PowerPoint.Application

Sub copyXL2PP()
'copy Excel worksheet used ranges to Powerpoint slides
Dim PPpres As PowerPoint.Presentation
Dim PPslide As PowerPoint.Slide
Dim PPShape As PowerPoint.Shape, PPTitle As PowerPoint.Shape, PPMain As PowerPoint.Shape
Dim ppLayout As PowerPoint.CustomLayout
Dim ws As Worksheet
Dim iSlide As Long, iMaxWidth As Long, iMaxHeight As Long, iChunkWidth As Long, iChunkHeight As Long, iCount As Long
Dim iLeft As Long, iTop As Long
Dim rAll As Range, rChunk As Range
   
'switch to Powerpoint or create new instance if program not running, calling function startPP
If Not startPP Then
MsgBox ("Can't start Powerpoint")
Exit Sub
End If

DoEvents
Set PPpres = PP.Presentations.Open("\\C:\Users\EOL EOS All Domains_Template.pptx")

'define standard layout based on first slide (change if needed)
Set ppLayout = PPpres.Slides(1).CustomLayout

'get basic frame size etc
iSlide = 4
PP.ActiveWindow.View.GotoSlide (iSlide)
Set PPslide = PPpres.Slides(iSlide)
'NB assumes each slide has a header and text area:
Set PPMain = PPslide.Shapes(2)
'get maximum width and height for image based on size of text area
iMaxWidth = PPMain.Width
iMaxHeight = PPMain.Height
'get left and top for image
iLeft = PPMain.Left
iTop = PPMain.Top

'Loop through worksheets
 For Each ws In Worksheets
    If (ws.Name) <> "EOS" Then
    ws.Activate
    'create range for all used cells
    Set rAll = ws.UsedRange
    'creat range to use for "chunk" copies
    Set rChunk = rAll
    
    'resize copy area to fit slide
    While rChunk.Width > iMaxWidth
    Set rChunk = rChunk.Resize(rChunk.Rows.Count, rChunk.Columns.Count - 1)
    Wend
    iChunkWidth = rChunk.Column + rChunk.Columns.Count
        
    While rChunk.Height > iMaxHeight
    Set rChunk = rChunk.Resize(rChunk.Rows.Count - 1, rChunk.Columns.Count)
    Wend
    iChunkHeight = rChunk.Column + rChunk.Columns.Count
    
    'count number of chunks used
    iCount = 1
    Do
      Do
        Application.CutCopyMode = False
        rChunk.Select
        rChunk.CopyPicture
        PP.ActiveWindow.View.GotoSlide (iSlide)
        Set PPslide = PPpres.Slides(iSlide)
        'set slide title based on worksheet name and chunk #
        Set PPTitle = PPslide.Shapes(1)
        PPTitle.TextFrame.TextRange = "Out of Support, " & ws.Name & " - section " & iCount
        'add image to slide:
        PPslide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
        Set PPShape = PPslide.Shapes(PPslide.Shapes.Count)
        'Set position:
        PPShape.Left = iLeft
        PPShape.Top = iTop
        'select next chunk to right
        Set rChunk = rChunk.Offset(0, iChunkWidth)
        'increment slide
        iSlide = iSlide + 1
            'add an extra slide if needed
            If iSlide > PPpres.Slides.Count Then
            PPpres.Slides.AddSlide iSlide, ppLayout
            End If
        'increment chunk count
        iCount = iCount + 1
        'loop until all of used area has been covered horizontally
        Loop Until rChunk.Column > rAll.Column + rAll.Columns.Count - 1
        
    'reset chunk to first column of used range and move down by chunk height
    Set rChunk = rChunk.Offset(iChunkHeight, -1 * (rChunk.Column - 1))
    'loop until all of used area has been covered vertically
    Loop Until rChunk.Row > rAll.Row + rAll.Rows.Count - 1
    
    
    End If

Next ws
       
    Application.CutCopyMode = False
    PP.Visible = True
    PP.Activate

End Sub

Select allOpen in new window

Function startPP() As Boolean
On Error GoTo errortrap
'initialize Powerpoint>>
'see if app is open:
Set PP = GetObject(, "Powerpoint.Application")
'if not, errorhandler will create an instance
PP.Visible = True
PP.Activate
startPP = True
Exit Function

errortrap:
Select Case Err.Number
'if can't access activeX object, then create one:
Case 429
Set PP = CreateObject("Powerpoint.Application")
DoEvents
Resume Next
Case Else
MsgBox (Err.Number & ": " & Err.Description)
startPP = False
End Select

End Function

Select allOpen in new window

'resize copy area to fit slide
    While rChunk.Width > iMaxWidth
    Set rChunk = rChunk.Resize(rChunk.Rows.Count, rChunk.Columns.Count - 1)
    Wend

Select allOpen in new window

rChunk.Select

Select allOpen in new window

'resize copy area to fit slide
  While rChunk.Width > iMaxWidth
          Set rChunk = rChunk.Resize(rChunk.Rows.Count, rChunk.Columns.Count - 1)
   Wend
          iChunkWidth = rChunk.Column + rChunk.Columns.Count
          
  While rChunk.Height > iMaxHeight
    Set rChunk = rChunk.Resize(rChunk.Rows.Count - 1, rChunk.Columns.Count)
 Wend
    iChunkHeight = rChunk.Column + rChunk.Columns.Count

Select allOpen in new window

Set PPMain = PPslide.Shapes(2)
'get maximum width and height for image based on size of text area
iMaxWidth = PPMain.Width
iMaxHeight = PPMain.Height

Select allOpen in new window

'resize copy area to fit slide
  While rChunk.Width > iMaxWidth
          Set rChunk = rChunk.Resize(rChunk.Rows.Count, rChunk.Columns.Count - 1)
   Wend
          iChunkWidth = rChunk.Column + rChunk.Columns.Count

Select allOpen in new window