Create ppt from Excel using macros

[mtrilce]

Hi Every one,

Thanks in advance for the help you can give me.


What I need is a macro that allows me to generate a ppt file from Excel, but considering that each Excel sheet a power point slide is generated, and in each case, the range to be copied is different.


I have a macro that lets me copy only the first sheet range ... How to adapt the macro to copy different ranges of different sheets?

Cheers

Marcela

[Paul_Hossler]

The "For Each ws in ThisWorkbook" and ".CurrentRegion" were the most significant changes

I just copied your ws 3 times to get some data to play with

Option Explicit
'PURPOSE: Copy/Paste An Excel Range Into a New PowerPoint Presentation
'SOURCE: www.TheSpreadsheetGuru.com

Sub ExcelRangeToPowerPoint()
    Dim rng As Range
    Dim PowerPointApp As Object
    Dim myPresentation As Object
    Dim mySlide As Object
    Dim myShape As Object
    Dim ws As Worksheet
    '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 worksheets
    For Each ws In ThisWorkbook.Worksheets
    
        'Add a slide to the Presentation
        Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly
        
        'Copy Excel Range
        ws.Range("A1").CurrentRegion.Copy
        
        'Paste to PowerPoint and position
        mySlide.Shapes.PasteSpecial DataType:=2         '   2 = ppPasteEnhancedMetafile
        Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
        
        'Set position:
        myShape.Left = 66
        myShape.Top = 152
    Next
    
    
    'Make PowerPoint Visible and Active
    PowerPointApp.Visible = True
    PowerPointApp.Activate
    
    'Clear The Clipboard
    Application.CutCopyMode = False
End Sub

[mtrilce]

Thanks so much Paul.

I really appreciate your help.


However, what I need is that different ranges of each sheet being copied. For example from sheet 1, range A1:C10; from sheet 2, range B2:E10, and so

Could you help me to solve it?

Cheers

Marcela

[Paul_Hossler]

Option Explicit

'PURPOSE: Copy/Paste An Excel Range Into a New PowerPoint Presentation
'SOURCE: www.TheSpreadsheetGuru.com

Dim PowerPointApp As Object
Dim myPresentation As Object

Sub ExcelRangeToPowerPoint()
    '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
    
    'copy worksheets into slide
    Call InsertSlideAndCopy(Worksheets("Company Data").Range("A1:C12"))
    Call InsertSlideAndCopy(Worksheets("Company Data (2)").Range("B2:D13"))
    Call InsertSlideAndCopy(Worksheets("Company Data (3)").Range("C3:E14"))
    Call InsertSlideAndCopy(Worksheets("Company Data (4)").Range("D4:F15"))
    
    'Make PowerPoint Visible and Active
    PowerPointApp.Visible = True
    PowerPointApp.Activate
    
    'Clear The Clipboard
    Application.CutCopyMode = False
End Sub
 

Private Sub InsertSlideAndCopy(R As Range)
    Dim mySlide As Object, myShape As Object
    
    'Add a slide to the Presentation
    Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly
    
    'Copy Excel Range
    R.Copy
    
    'Paste to PowerPoint and position
    mySlide.Shapes.PasteSpecial DataType:=2         '   2 = ppPasteEnhancedMetafile
    Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
    
    'Set position:
    myShape.Left = 66
    myShape.Top = 152

End Sub

[mtrilce]

That's great Paul, thank you very much again.


One last thing. I tried to copy a graph sheet 1, for which I stated the position of the graphic in the macro. By generating the ppt, this figure appeared in the last slide .. How can I do so that order is maintained, no matter whether table or graph?

[Paul_Hossler]

Well your .Slides.Add (1, 11) always adds the slide to the front as slide number 1

Set mySlide = myPresentation.slides.Add(1, 11) '11 = ppLayoutTitleOnly

Try this, note the lines marked with ------------------

Note that I separated the first sheet into two slides. You can change it back if you want

Option Explicit

Dim PowerPointApp As Object
Dim myPresentation As Object

Sub ExcelRangeToPowerPoint()
    '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
    
    'copy worksheets into slide
    Call InsertSlideAndCopy(Worksheets("Company Data").Range("A5:C16")) '-----------------
    Call InsertSlideAndCopy(Worksheets("Company Data").Shapes("Graph1")) '-----------------
    Call InsertSlideAndCopy(Worksheets("Company Data (2)").Range("B2:D13"))
    Call InsertSlideAndCopy(Worksheets("Company Data (3)").Range("C3:E14"))
    Call InsertSlideAndCopy(Worksheets("Company Data (4)").Range("D4:F15"))
    
    'Make PowerPoint Visible and Active
    PowerPointApp.Visible = True
    PowerPointApp.Activate
    
    'Clear The Clipboard
    Application.CutCopyMode = False
End Sub
 
Private Sub InsertSlideAndCopy(O As Object)
    Dim mySlide As Object, myShape As Object
    
    'Add a slide to the Presentation
    Set mySlide = myPresentation.slides.Add(myPresentation.slides.Count + 1, 11) '11 = ppLayoutTitleOnly    '----------------
    
    'Copy Excel Range
    O.Copy
    
    'Paste to PowerPoint and position
    mySlide.Shapes.PasteSpecial DataType:=2         '   2 = ppPasteEnhancedMetafile
    Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
    
    'Set position:
    myShape.Left = 66
    myShape.Top = 152

End Sub

[mtrilce]

That´s perfect Paul

Tranks so much

Marcela from Perú

[mtrilce]

Dear Paul


I come back to you on the same query. I had problems running the macro
I would like to know how to make the title of the ppt file slides the same title as the name of the copied graphics.


On the other hand, how could I copy only some graphics on a sheet?


Thank you very much for your help