VBA Loop to Copy Multiple Worksheets into PowerPoint

kiddzi

New Member
Joined
Jun 21, 2008
Messages
19
Hi,

I'm trying to figure out how to get the loop below to work correctly so would appreciate any help. :confused:

Essentially the loop needs to look in each worksheet and if there's a '1' in cell S1 to then copy & paste the range 'Print_Area' into a blank PowerPoint slide with a slide for each instance.

The code below adds in the right number of sheets but only pastes the first worksheet into all the slides which I want to change so that each instance has its own slide.

Thanks in advance for any help.

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


    'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
        For Each ws In ActiveWorkbook.Worksheets
            If ws.Range("S1") = "1" Then


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


            'Copy Excel Range
              rng.Copy


            'Paste to PowerPoint and position
              mySlide.Shapes.PasteSpecial DataType:=10  '2 = ppPasteEnhancedMetafile
              Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
  
                'Set position:
                  myShape.Left = 15
                  myShape.Top = 15
                  myShape.Width = 690
            End If
        Next ws
 

Excel Facts

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a $25,000 loan, 5% annual interest, 60 month loan.

Rorylfc

Board Regular
Joined
Jan 7, 2016
Messages
97
I see the rng.copy line,

Copy Excel Range
rng.Copy

but cannot see where you define what rng is!?! Could this be your issue?
 

kiddzi

New Member
Joined
Jun 21, 2008
Messages
19
I see the rng.copy line,

Copy Excel Range
rng.Copy

but cannot see where you define what rng is!?! Could this be your issue?


Thanks Rorylfc for your quick response. :)

I’ve now attached the full code below.

Code:
Sub ExcelRangeToPowerPoint()
'PURPOSE: Copy/Paste An Excel Range Into a New PowerPoint Presentation


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


'Copy Range from Excel
  Set rng = ThisWorkbook.ActiveSheet.Range("Print_Area")


'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


    'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
        For Each ws In ActiveWorkbook.Worksheets
            If ws.Range("S1") = "1" Then


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


            'Copy Excel Range
              rng.Copy


            'Paste to PowerPoint and position
              mySlide.Shapes.PasteSpecial DataType:=10  '2 = ppPasteEnhancedMetafile
              Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
  
                'Set position:
                  myShape.Left = 15
                  myShape.Top = 15
                  myShape.Width = 690
            End If
        Next ws
      
            'Make PowerPoint Visible and Active
              PowerPointApp.Visible = True
              PowerPointApp.Activate


            'Clear The Clipboard
              Application.CutCopyMode = False
  
End Sub
 

Rorylfc

Board Regular
Joined
Jan 7, 2016
Messages
97
I am still quite new to VBA, but could it be due to the Application.CutCopyMode - False, being outside the Loop. If it was inside the loop it would clear the clipboard before proceeding to the next worksheet
 

kiddzi

New Member
Joined
Jun 21, 2008
Messages
19

ADVERTISEMENT

Thanks Rorylfc.

I've moved the instruction to inside of the loop but it still has the same effect.
 

reitz1

New Member
Joined
Apr 14, 2021
Messages
1
Office Version
  1. 365
Platform
  1. Windows
I know this is an old thread, but i got it to work.
Set mySlide = myPresentation.Slides.Add(x, 12)
you need to have x as an integer and add x = x+1 inside the loop. you had (1, pplayoutblank) that will only add one slide. here is my code that worked.
so changed that to (x,12) 12 is blank form

Sub ExcelRangeToPowerPoint()
'PURPOSE: Copy/Paste An Excel Range Into a New PowerPoint Presentation


Dim rng As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim ws As Worksheet
Dim x As Integer

x = 0

'Copy Range from Excel
Set rng = ThisWorkbook.ActiveSheet.Range("Print_Area")


'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


'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
For Each ws In ActiveWorkbook.Worksheets
If ws.Range("S1") = "1" Then
'Copy Range from Excel
Set rng = ThisWorkbook.ActiveSheet.Range("Print_Area")
x = x + 1


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

'Copy Excel Range
rng.Copy


'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=10 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)

'Set position:
myShape.Left = 15
myShape.Top = 15
myShape.Width = 690
End If
Next ws

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


'Clear The Clipboard
Application.CutCopyMode = False

End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,130,215
Messages
5,640,918
Members
417,179
Latest member
DavidFamilytree

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top