We help IT Professionals succeed at work.

Is it possible to copy multiple slides from Powerpoint to Excel?

High Priority
138 Views
Last Modified: 2019-09-24
Is it possible to copy multiple slides from Powerpoint to Excel?

I want the slides as thumbnails for a project in excel and I can easily copy one slide at a time. However, when I select multiple slides in Powerpoint and try to paste them into Excel, only the first slide in the selection is pasted. If this can't be done manually, is there a VBA solution to the problem?
Comment
Watch Question

CERTIFIED EXPERT

Commented:
This isn't exactly the way you're asking to do it, but you could save the presentation as images, and then in Excel use insert> picture to insert all the images of the slides at once.
CERTIFIED EXPERT

Commented:
Can you setup an example of how and where you want to paste the slides?
Rob HensonFinance Analyst
CERTIFIED EXPERT

Commented:
Apologies for stating the obvious, have you checked the thumbnails aren't just stacked on top of each other with first slide on top so can see it??

Author

Commented:
Hi Rob - that was the first thing I checked. :-)

Author

Commented:
Hi Saqib - the images will be part of a table. Each slide is in a cell and is scaled to about 350mm high.

Author

Commented:
Hi Echo - not sure what you mean when you say save the presentation as images?
CERTIFIED EXPERT

Commented:
Just setup a dummy .ppt file with 3 or 4 slides and paste them in the .xlsx file and upload both files so that we know precisely what is to be done.

Author

Commented:
Powerpoint and Excel examples attached
Reception-Slides.pptx
Session-Plan.xlsx
CERTIFIED EXPERT
Commented:
Try this macro

Before using the macro you must enable the Microsoft excel module from

Tools > References

in the VBA window for Powerpoint


Sub a()
Dim sld As Slide
Dim xls As Excel.Application
Dim wb As Workbook
Dim ws As Worksheet
Dim sldno As Integer
Dim wsshapes As Excel.Shapes
Dim ccel As Range
Dim off As Integer
Set xls = GetObject(, "Excel.Application")
xls.ScreenUpdating = False

Set wb = xls.ActiveWorkbook
Set ws = wb.ActiveSheet
Set wsshapes = ws.Shapes
off = 4
With Application.ActivePresentation.Slides
    For sldno = 1 To .Count
        Set sld = .Item(sldno)
        sld.Copy
        Set ccel = ws.Cells(sldno + 4, 5)
        ws.Paste ccel
            wsshapes(wsshapes.Count).LockAspectRatio = msoFalse
            wsshapes(wsshapes.Count).Height = ccel.Height - off * 2
            wsshapes(wsshapes.Count).Width = ccel.Width - off * 2
            wsshapes(wsshapes.Count).Left = ccel.Left + off
            wsshapes(wsshapes.Count).Top = ccel.Top + off
            
    Next sldno
End With
xls.ScreenUpdating = True
End Sub

Open in new window

Author

Commented:
Hi Saqib

Not sure how to enable the Microsoft excel module from Tools > References. I can't find a 'Tools' option. I'm using office 365, latest version.

Regards

Terry

Author

Commented:
Sorry Saqib - found it, and the macro works perfectly. Many thanks.
Jamie GarrochPowerPoint Technical Consultant
CERTIFIED EXPERT

Commented:
I updated Saqib's macro to remove the dependency on the Ecel library and add erroro handling to make it a little more robust/future proof:

Option Explicit

' When developing, set this to true and add a refernce (Tools/Reference) to "Microsoft Excel XX.0 Object Library" to use IntelliSense.
' For production, remove the reference and set to False. If you don't do this, it will not work in earlier versions of Office.
#Const DEV_MODE = False

Sub CopySlideThumbnailsToExcel()
  ' PowerPoint objects
  Dim sld As Slide
  ' Excel Objects
  #If DEV_MODE Then                 ' Early Binding (requires a reference to the Excel library)
    Dim xls As Excel.Application
    Dim wb As Excel.Workbook
    Dim ws As Excel.Worksheet
    Dim wsshapes As Excel.Shapes
    Dim ccel As Excel.Range
  #Else
    Dim xls As Object               ' Late Binding
    Dim wb As Object
    Dim ws As Object
    Dim wsshapes As Object
    Dim ccel As Object
  #End If

  Dim sldno As Integer
  Dim off As Integer
  
  On Error Resume Next
  
  ' Get a reference to the Excel app
  Set xls = GetObject(, "Excel.Application")    ' Assumes Excel is open
  If Err Then
    Err.Clear
    Set xls = CreateObject("Excel.Application") ' Start Excel and create a new workbook
    If Err Then
      MsgBox "Couldn't start Excel", vbCritical + vbOKOnly, "Excel not found"
      Exit Sub
    End If
    xls.Workbooks.Add
    xls.Visible = True
  End If
  
  xls.ScreenUpdating = False
  
  Set wb = xls.ActiveWorkbook
  Set ws = wb.ActiveSheet
  Set wsshapes = ws.Shapes
  
  off = 4
  
  With Application.ActivePresentation.Slides
      For sldno = 1 To 10 '.Count
          Set sld = .Item(sldno)
          sld.Copy
          Set ccel = ws.Cells(sldno + 4, 5)
          ws.Paste ccel
              wsshapes(wsshapes.Count).LockAspectRatio = msoFalse
              wsshapes(wsshapes.Count).Height = ccel.Height - off * 2
              wsshapes(wsshapes.Count).Width = ccel.Width - off * 2
              wsshapes(wsshapes.Count).Left = ccel.Left + off
              wsshapes(wsshapes.Count).Top = ccel.Top + off
              
      Next sldno
  End With
  
  xls.ScreenUpdating = True
  
  On Error GoTo 0
End Sub

Open in new window