Export excel range as image/screenshot in PowerPoint

M

Mr.Karr

New member
Joined
Oct 21, 2014
Messages
13
Reaction score
0
Points
0
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.
 

Attachments

  • Export Excel Ranges As Power Point Tables_recent.xlsm
    25.7 KB · Views: 93
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.
 

Attachments

  • Export Excel Ranges As Power Point Tables_recent.xlsm
    27.2 KB · Views: 183
@Ken Puls: You're a champ!. thanks for the help
 
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
 
@snb: thanks for trying


snb said:
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
Click to expand...
 
@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
 
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 ?
 
@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.


snb said:
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 ?
Click to expand...
 
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.
 
@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!
 
You must log in or register to reply here.
Back
Top