Sunday, 14 April 2013



Export Excel Ranges As Power Point Tables

Some months ago I published a VBA code for exporting all Excel charts to a new Power Point presentation. Having read that post, a blog reader (Hari) asked me if is possible to transfer Excel data to Power Point. I sent him a code that I wrote on the fly, but I thought that a similar code will interest a lot of people who want to include Excel data to their presentations. So, I decided to improve the initial VBA code and here it is!

The code is consisted of two subs; the first one creates a new Power Point presentation and sets the Excel ranges that will be exported. For each range the second sub creates a new table in a new slide and fills that table with the corresponding range values. By setting the desired Excel range in the first sub you can adjust the VBA code according to your needs. In the attached workbook for example I have set a steady range for each worksheet and the first sub loops through all the worksheets of the workbook. Each worksheet contains the quarterly earnings from a hypothetical shop.


VBA 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 pptSlide        As PowerPoint.Slide
    Dim pptSlideCount   As Integer

Sub TablesToPowerPoint()
    
    'Exports the range A1:C5 from each sheet to a new Power Point
    'presentation as table. Each range is copied to a new slide.
        
    'By Christos Samaras
    'http://www.myengineeringworld.net
        
    Dim ws As Worksheet
          
    '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

    'Transfer the data from the range of each sheet (here A1:C5),
    'to the Power Point presentation. Note, that you can also use
    'the code with different ranges, like the example below:
    'Sheet1.Activate
    'ExcelTableToPowerPoint (ActiveSheet.Range("A1:B15"))
    'Sheet2.Activate
    'ExcelTableToPowerPoint (ActiveSheet.Range("B5:D10"))
    'In this workbook the range we want to export is the same in all
    'sheets, so a loop is used in order to make the code shorter.
    For Each ws In ActiveWorkbook.Worksheets
        ws.Activate
        ExcelTableToPowerPoint (ActiveSheet.Range("A1:C5"))
    Next ws
    
    'Return the "focus" to the frist sheet.
    ActiveWorkbook.Worksheets(1).Activate
    
    'Infrom the user that the macro finished.
    MsgBox "The ranges were successfully copied to the new presentation!", vbInformation, "Done"
    
End Sub

Private Sub ExcelTableToPowerPoint(xlRange As Range)
        
    'Copies an Excel Table to a Power Point table.
    
    'By Christos Samaras
    'http://www.myengineeringworld.net

    Dim pptTable            As Table
    Dim pptTableRows        As Long
    Dim pptTableColumns     As Long
    Dim pptTableRow         As Integer
    Dim pptTableCol         As Integer
    Dim pptMinTableWidth    As Single
    
    'Check if the range is valid.
    If Application.Intersect(xlRange, ActiveSheet.Range("A1:XFD1048576")) 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)
    
    'Add the table to a new slide. You can change the left property (35) and top
    'property (70) according to your own needs. You can also set the width (100) and
    'the height (200) of the table by using the following line:
    'pptSlide.Shapes.AddTable xlRange.Rows.Count, xlRange.Columns.Count, 35, 70, 100, 200
    pptSlide.Shapes.AddTable xlRange.Rows.Count, xlRange.Columns.Count, 35, 70
    Set pptTable = pptSlide.Shapes(pptSlide.Shapes.Count).Table
           
    'Pass the range values to the table.
    For pptTableRows = 1 To xlRange.Rows.Count
        For pptTableColumns = 1 To xlRange.Columns.Count
            pptTable.Cell(pptTableRows, pptTableColumns).Shape.TextFrame.TextRange.Text _
            = xlRange.Cells(pptTableRows, pptTableColumns)
            'Center alignment is used for cell contents.
            pptTable.Cell(pptTableRows, pptTableColumns).Shape.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
        Next pptTableColumns
    Next pptTableRows
    
    'Adjust the table width in order to save some slide space.
    With pptTable
        For pptTableCol = 1 To .Columns.Count
            For pptTableRow = 1 To .Rows.Count
                With .Cell(pptTableRow, pptTableCol).Shape.TextFrame
                    If pptMinTableWidth = 0 Then pptMinTableWidth = .TextRange.BoundWidth + .MarginLeft + .MarginRight + 1
                    If pptMinTableWidth < .TextRange.BoundWidth + .MarginLeft + .MarginRight + 1 Then _
                       pptMinTableWidth = .TextRange.BoundWidth + .MarginLeft + .MarginRight + 1
                End With
            Next
            .Columns(pptTableCol).Width = pptMinTableWidth
        Next
    End With
    
End Sub


Code results

The short video below demonstrates the results of the above VBA code.



Download it from here

The sample file will only work with Excel 2010 since it already have a reference to PowerPoint 14.0 Object Library. However, If you want to open it with Excel 2007 for example, open the file, switch to VBA editor (ALT + F11) and then from menu Tools -> References add a reference to the PowerPoint 12.0 Object Library. In any case, remember to enable macros before using it.


Read also

Export All Excel Charts To Power Point 

Did you like this post? If yes, then share it with your friends. Thank you!



Categories:


Mechanical Engineer (Ph.D. cand.), M.Sc. Cranfield University, Dipl.-Ing. Aristotle University, Thessaloniki - Greece.
Communication: tel. +30-6973513308, e-mail , Facebook , Twitter , Google+ and Linkedin . Full CV