Adapt macro that copies excel to ppt

[mtrilce]

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]

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]

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]

Excuse me! I forgot the attachment. Here it is