Как скопировать диапазон ячеек в виде таблицы из Excel в PowerPoint - VBA

Question

Я не могу найти способ сделать это.Теперь у меня есть то, что он копирует диапазон как изображение:

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

, это работает как талисман, но возможно ли получить его, чтобы скопировать диапазон как таблицу вместо изображения?

Answer 1

Это можно сделать просто с помощью

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

Answer 2

Ну, если бы я копировал это вручную, я бы, вероятно, сделал бы Специальную вставку и выбрал бы «Форматированный текст (RTF)» в качестве типа.Я уверен, что вы можете имитировать это в VBA.

Редактировать

Аа, вот так.Сделайте это в Powerpoint:

1. Перейдите на Вставка-> Объект
2. Выберите файл Excel.Проверьте параметр Ссылка .

Ссылка на файл XL теперь встроена в файл PP.Когда данные в вашем файле XL изменяются, вы можете:

1. Обновить их вручную с помощью Щелкните правой кнопкой мыши -> Обновить ссылку .
2. Обновите его автоматически с помощью VBA, используя что-то вроде ActivePresentation.UpdateLinks

Это совсем другой подход, чем то, что вы делали в первую очередь, но я считаю, что он приближает вас к вашей цели,Хотя у него есть свои проблемы, но они могут быть решены.

Answer 3

Выше предложенные решения не работали для меня, так как таблица Excel продолжала вставляться в powerpoint как (не редактируемое) изображение.

Для непосредственного запуска специальной кнопки «Сохранить исходное форматирование» на панели командв PowerPoint запустите следующий код:

Application.CommandBars.ExecuteMso ("PasteSourceFormatting")

Дополнительная (но ограниченная) информация на сайте Microsoft msdn: https://msdn.microsoft.com/en-us/library/office/ff862419.aspx

Answer 4

Просто нужно самому в этом разобраться.Вот специальная вставка, которая работает для меня:

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

Я нашел полный список специальных параметров вставки:

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

Answer 5

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