Results 1 to 10 of 10

Thread: Export excel range as image/screenshot in PowerPoint

  1. #1

    Export excel range as image/screenshot in PowerPoint



    Register for a FREE account, and/
    or Log in to avoid these ads!

    Hi,

    I am really struggling to get this working. Can anyone please help to modify the attached file to export range as image/screenshot in a PPT. Presently, it automates/exports ranges as a table in PPT.

    Please see the attached file.

    Many thanks in advance.
    Attached Files Attached Files

  2. #2
    Administrator Ken Puls's Avatar
    Join Date
    Mar 2011
    Location
    Nanaimo, BC, Canada
    Posts
    2,225
    Articles
    57
    Blog Entries
    14
    Excel Version
    Excel Office 365 Insider
    I've made your code a LOT shorter, but there's a couple of things you'll need to do to make this work:

    1. Define a named range called "rngPrintRanges" to cover Home-->J9:J12
    2. Modify your button to call the TablesToPowerPoint macro instead of the LoopIt macro


    Replace all the code in your mTablesToPowerPoint module with the following:

    Code:
    Option Explicit
        'Both subs require a reference to Microsoft PowerPoint xx.x Object Library.
        'where xx.x is your office version (11.0 = 2003, 12.0 = 2007 and 14.0 = 2010).
        'Declaring the necessary Power Point variables, whick are used in both subs.
        Dim pptApp          As PowerPoint.Application
        Dim pptPres         As PowerPoint.Presentation
        Dim pptSlideCount   As Integer
    Sub TablesToPowerPoint()
        Dim cl As Range
              
        'Open Power Point and create a new presentation.
        Set pptApp = New PowerPoint.Application
        Set pptPres = pptApp.Presentations.Add
        
        'Show the Power Point application.
        pptApp.Visible = True
        'Loop through tables of ranges
        Application.ScreenUpdating = False
        For Each cl In Worksheets("Home").Range("rngPrintRanges")
            Call ExcelTableToPowerPoint(cl.Value, cl.Offset(0, 1).Value)
        Next cl
        Application.ScreenUpdating = True
        
        'Inform the user that the macro finished.
        MsgBox "The ranges were successfully copied to the new presentation!", vbInformation, "Done"
        
    End Sub
    Private Sub ExcelTableToPowerPoint(xlSheet As String, xlRange As String)
        Dim pptSlide        As PowerPoint.Slide
        
        'Check if the range is valid.
        With Worksheets(xlSheet)
             If Application.Intersect(.Range(xlRange), .Cells) Is Nothing Then
                MsgBox "Sorry, the range you selected is not valid!", vbCritical, "Invalid range"
                Exit Sub
             End If
             
            'Count the slides and add a new one after the last slide.
            pptSlideCount = pptPres.Slides.Count
            Set pptSlide = pptPres.Slides.Add(pptSlideCount + 1, ppLayoutBlank)
            
            'Copy the range and paste as image
            .Range(xlRange).Copy
            pptSlide.Shapes.PasteSpecial (ppPasteMetafilePicture)
        End With
    End Sub
    That should do it for you. After that, just make sure the named range covers all of the Sheet names in column J of the home page, and you should be good to go.

    Sample attached.
    Attached Files Attached Files
    Ken Puls, FCPA, FCMA, MS MVP (Excel)

    Learn to Master Your Data at the Power Query Academy (the world's most comprehensive online Power Query training) or with my book M is for Data Monkey!

    Main Site: http://www.excelguru.ca -||- Blog: http://www.excelguru.ca/blog -||- Forums: http://www.excelguru.ca/forums
    Check out the Excelguru Facebook Fan Page -||- Follow Me on Twitter

    If you've been given VBA code (a macro) for your solution, but don't know where to put it, CLICK HERE.

  3. #3
    @Ken Puls: You're a champ!. thanks for the help

  4. #4
    Conjurer snb's Avatar
    Join Date
    May 2013
    Posts
    370
    Articles
    0
    Excel Version
    2020
    Code:
    Sub M_snb_009()
       Sheet1.Range("A1:E10").Copy
       
       With CreateObject("powerpoint.application")
            .Visible = True
            With .Presentations.Add
              With .Slides.Add(1, 2)
                .Shapes.PasteSpecial 1
              End With
            End With
        End With
    End Sub

  5. #5
    @snb: thanks for trying


    Quote Originally Posted by snb View Post
    Code:
    Sub M_snb_009()
       Sheet1.Range("A1:E10").Copy
       
       With CreateObject("powerpoint.application")
            .Visible = True
            With .Presentations.Add
              With .Slides.Add(1, 2)
                .Shapes.PasteSpecial 1
              End With
            End With
        End With
    End Sub

  6. #6
    @ken Puls:

    Sorry I forgot to mention this before.
    Can we make the copied range to occupy the entire PPT leaving the title space? Please help

  7. #7
    Conjurer snb's Avatar
    Join Date
    May 2013
    Posts
    370
    Articles
    0
    Excel Version
    2020
    Did you use my suggestion ?
    The result is exactly what you were asking for !
    Did you adapt Sheet1 to the situation in the workbook you are testing ?

  8. #8
    @snb:

    There is a main thing which is missing with the snippet you've provided. The 'dynamic' way to capture ranges from sheet1. However from the code you've provided will only perform single slide which is : Sheet1.Range("A1:E10").Copy

    Please see the initial request, kindly.


    Quote Originally Posted by snb View Post
    Did you use my suggestion ?
    The result is exactly what you were asking for !
    Did you adapt Sheet1 to the situation in the workbook you are testing ?

  9. #9
    Conjurer snb's Avatar
    Join Date
    May 2013
    Posts
    370
    Articles
    0
    Excel Version
    2020
    You initial request isn't mentioning any dynamically selection of ranges.

    Bus besides: we do not provide solutions, you will have to hire a developer for that.
    We provide suggestions how you can accomplish your goal yourself.
    So you can easily adapt the suggestion I provided, and I advise you to do so.

  10. #10
    @Ken Puls / snb:

    When I set pptSlide = ppLayoutTitleOnly, the shape is pasted inside it. That's not what we not expect to happen rite.

    Can you please look into this & modify the code a bit to change the pptSlide to pplayoutTitleOnly and also modify the properties of the title to fit with the properties of the shape:

    Code:
    Option Explicit
    
        'Both subs require a reference to Microsoft PowerPoint xx.x Object Library.
        'where xx.x is your office version (11.0 = 2003, 12.0 = 2007 and 14.0 = 2010).
    
    
        'Declaring the necessary Power Point variables, whick are used in both subs.
        Dim pptApp          As PowerPoint.Application
        Dim pptPres         As PowerPoint.Presentation
        Dim pptSlideCount   As Integer
    
    
    Sub TablesToPowerPoint()
    
    
    On Error Resume Next
        Dim cl As Range
              
        'Open Power Point and create a new presentation.
        Set pptApp = New PowerPoint.Application
        Set pptPres = pptApp.Presentations.Add
        
        'Show the Power Point application.
        pptApp.Visible = True
    
    
        'Loop through tables of ranges
        Application.ScreenUpdating = False
        For Each cl In Worksheets("Home").Range("rngPrintRanges")
            Call ExcelTableToPowerPoint(cl.Value, cl.Offset(0, 1).Value)
        Next cl
        Application.ScreenUpdating = True
        
        'Inform the user that the macro finished.
        MsgBox "The ranges were successfully copied to the new presentation!", vbInformation, "Done"
        
    End Sub
    
    
    Private Sub ExcelTableToPowerPoint(xlSheet As String, xlRange As String)
        Dim pptSlide        As PowerPoint.Slide
        
        'Check if the range is valid.
        With Worksheets(xlSheet)
             If Application.Intersect(.Range(xlRange), .Cells) Is Nothing Then
                MsgBox "Sorry, the range you selected is not valid!", vbCritical, "Invalid range"
                Exit Sub
             End If
             
            'Count the slides and add a new one after the last slide.
            pptSlideCount = pptPres.Slides.Count
            Set pptSlide = pptPres.Slides.Add(pptSlideCount + 1, ppLayoutBlank)
            
            'Copy the range and paste as image
            .Range(xlRange).Copy
            pptSlide.Shapes.PasteSpecial (ppPasteMetafilePicture)
        End With
        
        With pptSlide.Shapes(1)
        'pptApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = False
        .Top = 60
        .Left = 10
        .Height = 540
        .Width = 940
    End With
    
    
    End Sub
    Code:
     With pptSlide.Shapes(1)    'pptApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = False
        .Top = 60
        .Left = 10
        .Height = 540
        .Width = 940
    End With
    Please see the attachment above.

    Many thanks!

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •