VBA Loop to Copy Multiple Worksheets into PowerPoint

K

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

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.
Sort by date Sort by votes
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?
 
Upvote 0
Rorylfc said:
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?
Click to expand...


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
 
Upvote 0
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
 
Upvote 0
Thanks Rorylfc.

I've moved the instruction to inside of the loop but it still has the same effect.
 
Upvote 0
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
 
Upvote 0
Hi apologises i know this is an old thread but am trying to use the above code and struggling with it. I have made some amendments to it to fit my requirements.

Basically its the if loop i cant get right, i need it to skip the first sheet called 'Dashboard' but then for each sheet afterwards if the cell W4 is equal to "Yes" then copy a range as an image into the power point silde. Basicallly the excel document has 11 sheets including the dashboard. each month we may only need 3 of the sheets and the other 7 can be ignored.

any help with this would be much appreciated.

Sub NewExcelToPowerpoint()

'Step 1: Declare Variables
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("A1:S43")

'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
Set rng = ThisWorkbook.ActiveSheet.Range("A1:S43")
If ws.Range("W4") = "Yes" Then
'Copy Range from Excel
x = x + 1

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

'Copy Excel Range
rng.CopyPicture

'Paste to PowerPoint and position
mySlide.Shapes.Paste

End If
Next ws

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


'Clear The Clipboard
Application.CutCopyMode = False

End Sub
 
Upvote 0
chris_united said:
Hi apologises i know this is an old thread but am trying to use the above code and struggling with it. I have made some amendments to it to fit my requirements.

Basically its the if loop i cant get right, i need it to skip the first sheet called 'Dashboard' but then for each sheet afterwards if the cell W4 is equal to "Yes" then copy a range as an image into the power point silde. Basicallly the excel document has 11 sheets including the dashboard. each month we may only need 3 of the sheets and the other 7 can be ignored.

any help with this would be much appreciated.

Sub NewExcelToPowerpoint()

'Step 1: Declare Variables
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("A1:S43")

'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
Set rng = ThisWorkbook.ActiveSheet.Range("A1:S43")
If ws.Range("W4") = "Yes" Then
'Copy Range from Excel
x = x + 1

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

'Copy Excel Range
rng.CopyPicture

'Paste to PowerPoint and position
mySlide.Shapes.Paste

End If
Next ws

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


'Clear The Clipboard
Application.CutCopyMode = False

End Sub
Click to expand...
I dont have time to decipher yours, but i will post my latest working loop. it does error out at the end after the last worksheet. i cant get a good end, but it works beautiful for me
 
Upvote 0
This is my most up to date loop...works great, but I error out after the last sheet, but it works. it errors out at Next WS
I utilize 3 numbers to decipher how i want the page to look, so you can go down to 1 or whatever.

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

Dim sht As Worksheet
Dim rng As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim mytitle As Object
Dim stitle As Range
Dim WS As Worksheet
Dim x As Integer




 x = 0
Set WS = ActiveSheet

'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
       
       
          
    'tests if sheet should become slide and what size shape
            If WS.Range("D2") = "1" Or WS.Range("D2") = "2" Or WS.Range("D2") = "3" Then
'           If WS.Range("D2") = "1" Then    'used for testing

'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, 11) '11 = ppLayoutTitleOnly, 12 is blank


            'Copy Excel Range
''            If ws.Range("S1") = "1" Then 'Or ws.Range("S1") = "2" Then
            'Set rng = ThisWorkbook.ActiveSheet.Range("Print_Area")
            'can change the below to print area, but the size of slide is
            'determmined by the 1, 2, 3 numbers in D2
            Set rng = ThisWorkbook.ActiveSheet.Range("D4:J30")
            Set rng2 = ThisWorkbook.ActiveSheet.Range("D5:t29")
            Set rng3 = ThisWorkbook.ActiveSheet.Range("D5:t35")
            Set stitle = ThisWorkbook.ActiveSheet.Range("D1")
             
            If WS.Range("D2") = "1" Then rng.Copy
            If WS.Range("D2") = "2" Then rng2.Copy
            If WS.Range("D2") = "3" Then rng3.Copy
            'rng.Copy
       
        '''Else


            'Paste to PowerPoint and position
              mySlide.Shapes.PasteSpecial DataType:=10  '2 = ppPasteEnhancedMetafile
              Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
            
            If WS.Range("D2") = "1" Then
             myShape.LockAspectRatio = msoFalse
               myShape.ScaleHeight 1.04, msoTrue
               myShape.ScaleWidth 1.07, msoTrue
                myShape.Left = 1.56 * 72
                myShape.Top = 1.28 * 72
                If Range("color") = "white" Then
                myShape.Fill.ForeColor.RGB = RGB(255, 255, 255)
                ''Else
                ''myShape.Fill.ForeColor.RGB = RGB(195, 15, 10)
                End If
                ' myShape.Fill.ForeColor.RGB = Color1  'RGB(255, 255, 255) 'White
            End If
           
          If WS.Range("D2") = "2" Then
             myShape.LockAspectRatio = msoFalse
               myShape.ScaleHeight 1.14, msoTrue
               myShape.ScaleWidth 0.89, msoTrue
                myShape.Left = 0.18 * 72
                myShape.Top = 1.28 * 72
                If Range("color") = "white" Then
                myShape.Fill.ForeColor.RGB = RGB(255, 255, 255)
                ''Else
                ''myShape.Fill.ForeColor.RGB = RGB(195, 15, 10)
                End If
                'myShape.Fill.ForeColor.RGB = Color1 ' RGB(255, 255, 255)
            End If
           
            If WS.Range("D2") = "3" Then
             myShape.LockAspectRatio = msoFalse
            myShape.Height = 5.25 * 72
              myShape.Width = 12.71 * 72
                myShape.Left = 0.22 * 72
                myShape.Top = 1.28 * 72
               If Range("color") = "white" Then
                myShape.Fill.ForeColor.RGB = RGB(255, 255, 255)
                ''Else
                ''myShape.Fill.ForeColor.RGB = RGB(195, 15, 10)
                End If
                             
               ' myShape.Fill.ForeColor.RGB = Color1  'RGB(255, 255, 255)
            End If
               
     'If mySlide.Shapes.HasTitle Then mySlide.Shapes.Title.TextFrame.TextRange = "New title"
  If mySlide.Shapes.HasTitle Then mySlide.Shapes.Title.TextFrame.TextRange = stitle
 
  Set mytitle = mySlide.Shapes(1)
'''''''  Set mytitle = mySlide.Shapes.Title
              mytitle.LockAspectRatio = msoFalse
                mytitle.Left = 72 * 0#
               mytitle.Top = 72 * -0.17
       
        With mytitle.TextFrame.TextRange.Font
        .Size = 28
        .Name = "Arial"
        .Bold = True
        'red
        '.Color.RGB = RGB(194, 15, 47)
        'blue
        .Color.RGB = RGB(30, 49, 118)

         End With
   
           
 End If
 
 
 
           WS.Next.Activate
            ''Loop
 
 
       Next WS
 
 
            'Make PowerPoint Visible and Active
              PowerPointApp.Visible = True
              PowerPointApp.Activate


            'Clear The Clipboard
              Application.CutCopyMode = False
 
  Worksheets("Dashboard").Activate
  Range("e13").Select
   
  MsgBox "All Sheets have been made"
 
   Worksheets("Dashboard").Activate
   Range("e13").Select
  
  
End Sub
 
Last edited by a moderator:
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question
VBA Copy from Excel, Paste to Powerpoint
Replies
1
Views
515
SeniorNewbie
SeniorNewbie
S
  • Question
VBA code for Excel tables into ppt - automation
Replies
3
Views
2K
Trebor76
T
F
  • Question
Excel VBA to Powerpoint - paste special chart object link
Replies
3
Views
957
Domenic
D
B
  • Question
Excel to PowerPoint - Was working, not generating error....
Replies
1
Views
684
BuJay
B
C
  • Question
Replacing PowerPoint Input using Find and Replace Arrays from Excel through VBA
Replies
0
Views
1K
ckcs
C

Forum statistics

Threads
1,214,819
Messages
6,121,741
Members
449,050
Latest member
excelknuckles

Share this page

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
Back
Top