PDA

View Full Version : Adapt macro that copies excel to ppt



mtrilce
12-10-2016, 09:45 AM
Dear Friends,


I would like to modify this macro so that each slide generated in the PPT file is titled the same name as the graphics or tables copied on that slide:

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("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



I will greatly appreciate your help.


Regards,


Marcela

Kenneth Hobs
12-10-2016, 04:12 PM
Do you mean add a textbox title? This might give you an idea.

'http://www.mrexcel.com/forum/excel-questions/968661-copy-chart-excel-powerpoint.html

Sub Chart1ToPPT()


Dim ppApp As PowerPoint.Application
Dim ppPres As PowerPoint.Presentation
Dim ppSlide As PowerPoint.Slide
Dim ppTextbox As PowerPoint.Shape

Set ppApp = New PowerPoint.Application

ppApp.Visible = msoCTrue
ppApp.Activate
Set ppPres = ppApp.Presentations.Add

Set ppSlide = ppPres.Slides.Add(1, ppLayoutTitle)
ppSlide.Shapes(1).TextFrame.TextRange.Text = "Copying a chart"
ppSlide.Shapes(2).TextFrame.TextRange.Text = "A programmer"
Set ppSlide = ppPres.Slides.Add(2, ppLayoutBlank)
ppSlide.Select

'Chart1.ChartArea.Copy
ActiveSheet.Shapes("Chart 1").Copy

ppSlide.Shapes.Paste.Select 'ADD A BREAKPOINT HERE

ppSlide.Shapes(1).Width = ppPres.PageSetup.SlideWidth
ppSlide.Shapes(1).Left = 0

ppSlide.Shapes(1).Top = (ppPres.PageSetup.SlideHeight / 2) - (ppSlide.Shapes(1).Height / 2)

Set ppTextbox = ppSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 20, ppPres.PageSetup.SlideWidth, 60)

With ppTextbox.TextFrame

.TextRange.Text = "List of Current Films"
.TextRange.ParagraphFormat.Alignment = ppAlignCenter
.TextRange.Font.Size = 26
.TextRange.Font.Name = "Calibri"
.VerticalAnchor = msoAnchorMiddle

End With


End Sub




Sub Test()


Dim ppApp As PowerPoint.Application
Dim ppPres As PowerPoint.Presentation
Dim ppSlide As PowerPoint.Slide
Dim ppTextbox As PowerPoint.Shape

Set ppApp = New PowerPoint.Application

ppApp.Visible = msoCTrue
ppApp.Activate
Set ppPres = ppApp.Presentations.Add

Set ppSlide = ppPres.Slides.Add(1, ppLayoutTitle)
ppSlide.Shapes(1).TextFrame.TextRange.Text = "Copying a chart"
ppSlide.Shapes(2).TextFrame.TextRange.Text = "A programmer"
Set ppSlide = ppPres.Slides.Add(2, ppLayoutBlank)
ppSlide.Select

Chart1.ChartArea.Copy

ppSlide.Shapes.Paste.Select 'ADD A BREAKPOINT HERE

ppSlide.Shapes(1).Width = ppPres.PageSetup.SlideWidth
ppSlide.Shapes(1).Left = 0

ppSlide.Shapes(1).Top = (ppPres.PageSetup.SlideHeight / 2) - (ppSlide.Shapes(1).Height / 2)

Set ppTextbox = ppSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 20, ppPres.PageSetup.SlideWidth, 60)

With ppTextbox.TextFrame

.TextRange.Text = "List of Current Films"
.TextRange.ParagraphFormat.Alignment = ppAlignCenter
.TextRange.Font.Size = 26
.TextRange.Font.Name = "Calibri"
.VerticalAnchor = msoAnchorMiddle

End With


End Sub

mtrilce
12-10-2016, 04:55 PM
Dear Keneth


Thanks for helping.


What I really need is that each slide is titled with the name of the graphic that has been copied into it. If you also include a slide at the beginning with the name of the entire presentation (as the example you have sent me), much better.


I tried to apply the macro in this attachment. I put two buttons, one red and one blue, but in both I have problems


If you can help me a little more, I'll really appreciate it.


Greetings from Peru


Marcela

mtrilce
12-10-2016, 04:56 PM
Excuse me! I forgot the attachment. Here it is