How to copy cell range as table from Excel to PowerPoint - VBA

I can't find any way to do this. What I have now is that it copy the range as an image:

Dim XLApp As Excel.Application 
Dim PPSlide As Slide 

Set XLApp = GetObject(, "Excel.Application") 
XLApp.Range("A1:B17").Select 
XLApp.Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
PPSlide.Shapes.Paste.Select

this works like a charm, but is it possible to get it to copy the range as a table instead of picture?

This can be done simply with

Dim XLApp As Excel.Application
Dim PPSlide As Slide

Set XLApp = GetObject(, "Excel.Application")
XLApp.Range("A1:B17").Copy
PPSlide.Shapes.PasteSpecial DataType:=ppPasteOLEObject, Link:=msoFalse

Well, if I was copying it manually, I would probably do a Paste Special and choose "Formatted Text (RTF)" as the type. I'm sure you can mimic that in VBA.

Edit

Aah, here we go. Do this in your powerpoint:

Go to Insert->Object
Choose your Excel file. Check the Link option.

A link to your XL file is now embedded in your PP file. When the data in your XL file changes, you can:

Update it manually by Right-Click->Update Link.
Update it automatically by VBA by using something like ActivePresentation.UpdateLinks

This is a very different approach than what you were doing first, but I believe it gets you closer to your goal. It has it own problems, though, but those can be worked out.

Just needing to figure this out myself. Here's the paste special that worked for me:

XLApp.Selection.Copy
PPSlide.Shapes.PasteSpecial DataType:=ppPasteDefault

I found the full list of special paste options here:

http://www.thespreadsheetguru.com/blog/2014/3/17/copy-paste-an-excel-range-into-powerpoint-with-vba

The above proposed solutions did not work for me as the excel table continued being pasted in powerpoint as a (non-editable) picture.

To directly run the pastespecial 'Keep Source Formatting' button in the commandbar in powerpoint run following code:

Application.CommandBars.ExecuteMso ("PasteSourceFormatting")

More (but limited) info on Microsoft msdn site: https://msdn.microsoft.com/en-us/library/office/ff862419.aspx

Sub abc()

j = 2
Sheets("sheet1").Select

ActiveSheet.Range("a1").Select
ActiveSheet.Range("a65536").Select
lastrow = Selection.End(xlUp).Row

'/// column a
ActiveSheet.Range("a3:a" & lastrow).Select

Application.CutCopyMode = False
    Selection.AutoFilter
    ActiveSheet.Range("$A$3:$A$" & lastrow).AutoFilter Field:=1, Criteria1:="="

Set Rng = ActiveSheet.AutoFilter.Range

cnt = Rng.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1

   If cnt = 0 Then
   GoTo label1
   End If

    ActiveSheet.Range("a3:a" & lastrow - 1).Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Copy



    'Selection.EntireRow.Select

'    Range(Selection, Selection.End(xlToRight)).Select
    rownum = Selection.Row

'    If rownum = 3 Then
'    Selection.AutoFilter
'    GoTo label1
'    End If

    'Selection.Copy
    Sheets("Sheet2").Select
    'lrow = ActiveSheet.Range("A65536").End(xlUp).Row

    lrow = Cells.Find(what:="*", after:=[a1], searchorder:=xlByRows, _
    searchdirection:=xlPrevious).Row

    ActiveSheet.Range("a" & lrow + 1).Select
    ActiveSheet.Paste
    Sheets("Sheet1").Select
    Selection.Offset(1, 0).SpecialCells(xlCellTypeVisible).Select

    Selection.EntireRow.Delete
     Application.CutCopyMode = False

label1:
 Selection.AutoFilter

'column b///////////


ActiveSheet.Range("a65536").Select
lastrow = Selection.End(xlUp).Row
ActiveSheet.Range("b3:b" & lastrow).Select
    Application.CutCopyMode = False
    Selection.AutoFilter
    ActiveSheet.Range("$b$3:$b$" & lastrow).AutoFilter Field:=1, Criteria1:="="

    Set Rng = ActiveSheet.AutoFilter.Range

cnt = Rng.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1

   If cnt = 0 Then
   GoTo label2
   End If

        ActiveSheet.Range("$b$3:$b$" & lastrow - 1).Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Copy

    'Range(Selection, Selection.End(xlToLeft)).Select
    '
   ' Selection.EntireRow.Select

    'Range(Selection, Selection.End(xlToRight)).Select

'    rownum = Selection.Row
'    If rownum = 3 Then
'    Selection.AutoFilter
'    GoTo label2
'    End If

   ' Selection.Copy
    Sheets("Sheet2").Select
    'lrow = ActiveSheet.Range("A65536").End(xlUp).Row

    lrow = Cells.Find(what:="*", after:=[a1], searchorder:=xlByRows, _
    searchdirection:=xlPrevious).Row

    ActiveSheet.Range("a" & lrow + 1).Select
    ActiveSheet.Paste
    Sheets("Sheet1").Select

    'Selection.SpecialCells(xlCellTypeVisible).Select

'Selection.Offset(1, 0).SpecialCells(xlCellTypeVisible).Select
'
'    Selection.EntireRow.Delete

    ActiveSheet.Range("$b$3:$b$" & lastrow - 1).Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    Application.CutCopyMode = False

label2:
     Selection.AutoFilter

    'column c////////////


    ActiveSheet.Range("c65536").Select
lastrow = Selection.End(xlUp).Row
 ActiveSheet.Range("c3:c" & lastrow).Select
    Application.CutCopyMode = False
    Selection.AutoFilter
    ActiveSheet.Range("$c$3:$c$" & lastrow).AutoFilter Field:=1, Criteria1:="SG Plus", _
    Operator:=xlOr, Criteria2:="=Select"

Set Rng = ActiveSheet.AutoFilter.Range

cnt = Rng.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1

   If cnt = 0 Then
   GoTo label3
   End If

            ActiveSheet.Range("$c$3:$c$" & lastrow - 1).Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Copy

    'Range(Selection, Selection.End(xlToRight)).Select
'    Selection.Copy
'    Sheets("Sheet2").Select
'    lrow = activehseet.Range("A65536").End(xlUp).Row
'    ActiveSheet.Range("a" & lrow).Select
'    ActiveSheet.Paste
'    Sheets("Sheet1").Select



'    rownum = Selection.Row
'    If rownum = 3 Then
'    Selection.AutoFilter
'    GoTo label3
'    End If

'    Range("a4:a" & lastrow).Select
'    Range(Selection, Selection.End(xlToRight)).Select
'    Selection.EntireRow.Select
'    Selection.SpecialCells(xlCellTypeVisible).Select


            ActiveSheet.Range("$c$3:$c$" & lastrow - 1).Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Select

    Selection.EntireRow.Delete
        Application.CutCopyMode = False


label3:
 Selection.AutoFilter


'column c again/////////////


    ActiveSheet.Range("c65536").Select
lastrow = Selection.End(xlUp).Row

ActiveSheet.Range("c3:c" & lastrow).Select
    Application.CutCopyMode = False
    Selection.AutoFilter
    ActiveSheet.Range("$c$3:$c$" & lastrow).AutoFilter Field:=1, Criteria1:="="

    Set Rng = ActiveSheet.AutoFilter.Range

cnt = Rng.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1

   If cnt = 0 Then
   GoTo label4
   End If

                ActiveSheet.Range("$c$3:$c$" & lastrow - 1).Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Copy



'    rownum = Selection.Row
'    If rownum = 3 Then
'    Selection.AutoFilter
'    GoTo label4
'    End If
'
'    Range(Selection, Selection.End(xlToRight)).Select
'
'        Range("a4:a" & lastrow).Select
'    Range(Selection, Selection.End(xlToRight)).Select
'
'    Selection.EntireRow.Copy
    Sheets("Sheet2").Select
    'lrow = ActiveSheet.Range("A65536").End(xlUp).Row

    lrow = Cells.Find(what:="*", after:=[a1], searchorder:=xlByRows, _
    searchdirection:=xlPrevious).Row

    ActiveSheet.Range("a" & lrow + 1).Select
    ActiveSheet.Paste
    Sheets("Sheet1").Select

                    ActiveSheet.Range("$c$3:$c$" & lastrow - 1).Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Select

 '   Selection.SpecialCells(xlCellTypeVisible).Select

    Selection.EntireRow.Delete
        Application.CutCopyMode = False

label4:
    Selection.AutoFilter

'//////////////////////////  over  /////////////////////////////



ActiveSheet.Range("a1").Select
For i = 4 To lastrow
Range("a" & i).Select
If Range("a" & i).Value = "MidAmerica" Or Range("a" & i).Value = "Northeast" Or Range("a" & i).Value = "Southeast" Or _
Range("a" & i).Value = "West" Then
GoTo cont
Else

Rows(i).Select
Application.CutCopyMode = False
Selection.Cut
    Sheets("Sheet2").Select

        lrow = Cells.Find(what:="*", after:=[a1], searchorder:=xlByRows, _
    searchdirection:=xlPrevious).Row

    Range("a" & lrow + 1).Select
    ActiveSheet.Paste
    j = j + 1
    Sheets("sheet1").Select
       Selection.Delete Shift:=xlUp
   End If
cont:
Next i


'/////// column b ///////////

ActiveSheet.Range("a1").Select
For i = 4 To lastrow
Range("b" & i).Select
If Range("b" & i).Value = "CA" Or Range("b" & i).Value = "AZ" Then
GoTo cont2
Else

Rows(i).Select
Application.CutCopyMode = False
Selection.Cut
    Sheets("Sheet2").Select
    lrow = Cells.Find(what:="*", after:=[a1], searchorder:=xlByRows, _
    searchdirection:=xlPrevious).Row
    Range("a" & lrow + 1).Select
    ActiveSheet.Paste
    j = j + 1
    Sheets("sheet1").Select
    Selection.Delete Shift:=xlUp
   End If
cont2:
Next i

'///////////column c //////////

ActiveSheet.Range("a1").Select
For i = 4 To lastrow
Range("c" & i).Select
If Range("c" & i).Value = "SG" Then
GoTo cont3
Else

Rows(i).Select
Application.CutCopyMode = False
Selection.Cut
    Sheets("Sheet2").Select
    lrow = Cells.Find(what:="*", after:=[a1], searchorder:=xlByRows, _
    searchdirection:=xlPrevious).Row

    Range("a" & lrow + 1).Select
    ActiveSheet.Paste
    j = j + 1
    Sheets("sheet1").Select
    Selection.Delete Shift:=xlUp
   End If
cont3:
Next i

'//////////column l/////////////
ActiveSheet.Range("a1").Select
For i = 4 To lastrow
Range("l" & i).Select
If Range("l" & i).Value <= "01/06/2014" And Range("l" & i).Value >= "01/01/2013" Then
GoTo cont4
Else

Rows(i).Select
Application.CutCopyMode = False
Selection.Cut
    Sheets("Sheet2").Select

        lrow = Cells.Find(what:="*", after:=[a1], searchorder:=xlByRows, _
    searchdirection:=xlPrevious).Row

    Range("a" & lrow + 1).Select
    ActiveSheet.Paste
    j = j + 1
    Sheets("sheet1").Select
    Selection.Delete Shift:=xlUp
   End If
cont4:
Next i

'//////////column m/////////////
ActiveSheet.Range("a1").Select
For i = 4 To lastrow
Range("m" & i).Select
If Range("m" & i).Value = "12/01" Or Range("m" & i).Value = "12/05" Then
GoTo cont5
Else

Rows(i).Select
Application.CutCopyMode = False
Selection.Cut
    Sheets("Sheet2").Select

        lrow = Cells.Find(what:="*", after:=[a1], searchorder:=xlByRows, _
    searchdirection:=xlPrevious).Row


    Range("a" & lrow + 1).Select
    ActiveSheet.Paste
    j = j + 1
    Sheets("sheet1").Select
    Selection.Delete Shift:=xlUp
   End If
cont5:
Next i

'//////////column q and r/////////////
ActiveSheet.Range("a1").Select
For i = 4 To lastrow
Range("q" & i).Select
If Range("q" & i).Value <> " " And Range("r" & i).Value <> " " And Range("u" & i).Value <> " " _
And Range("z" & i).Value <> " " And Range("aa" & i).Value <> " " And Range("ab" & i).Value <> " " _
And Range("b" & i).Value <> " " And Range("j" & i).Value <> " " Then
GoTo cont6
Else

Rows(i).Select
Application.CutCopyMode = False
Selection.Cut
    Sheets("Sheet2").Select

        lrow = Cells.Find(what:="*", after:=[a1], searchorder:=xlByRows, _
    searchdirection:=xlPrevious).Row

    Range("a" & lrow + 1).Select
    ActiveSheet.Paste
    j = j + 1
    Sheets("sheet1").Select
    Selection.Delete Shift:=xlUp
   End If
cont6:
Next i


End Sub

来源：https://stackoverflow.com/questions/3840370/how-to-copy-cell-range-as-table-from-excel-to-powerpoint-vba

标签

excel

vba

powerpoint