PDA

View Full Version : Create ppt from Excel using macros



mtrilce
09-30-2016, 11:51 AM
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
09-30-2016, 06:25 PM
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 (http://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
10-03-2016, 07:56 AM
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
10-03-2016, 08:56 AM
Option Explicit

'PURPOSE: Copy/Paste An Excel Range Into a New PowerPoint Presentation
'SOURCE: www.TheSpreadsheetGuru.com (http://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
10-03-2016, 09:15 AM
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
10-03-2016, 11:37 AM
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
10-03-2016, 11:52 AM
That´s perfect Paul

Tranks so much

Marcela from Perú

mtrilce
12-08-2016, 03:03 PM
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