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

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

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

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

 KevenDenen01 окт. 2010 г., 17:25
Почему вы задаете один и тот же вопрос дважды?
 iper01 окт. 2010 г., 17:29
Извините, но я не могу войти в систему с учетной записью, с которой я разместил последний вопрос, и в разметке была неразбериха. Поэтому я подумал, что было бы лучше спросить это снова с правильно отформатированным кодом.

Ответы на вопрос(5)

которая работала для меня:

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

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

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

Ааа, вот и мы. Сделайте это в своем powerpoint:

Идти кВставка-> ObjectВыберите файл Excel. ПроверитьСсылка на сайт вариант.

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

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

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

 PowerUser01 окт. 2010 г., 18:31
Хм, почему вы не можете использовать методы PasteExcelTable? Какая у вас ошибка?
 PowerUser31 янв. 2011 г., 16:15
@ Дэйв Дуплантис, я согласен, что решение Саймона намного проще моего (еще не пробовал, но оно должно работать). Тем не менее, вы отрицаете меня, потому что лучшее решение было опубликовано в течение 3 месяцевпосле мой. И никто больше ничего об этом не говорил за все это время. На твоем месте, я бы просто одобрил решение Саймона, сделал комментарий и оставил это на этом.
 PowerUser04 окт. 2010 г., 14:53
Позвольте мне сказать прямо: у вас есть исходный документ xml, который передает данные в файл Excel, который передает данные в powerpoint? Что если вы просто смоделируете powerpoint в Excel? 1 меньше формата для беспокойства.
 PowerUser01 окт. 2010 г., 21:51
Смотрите мой Edit выше. Альтернативный подход.
 Dave DuPlantis28 янв. 2011 г., 22:40
Проголосовал (возможно, резко), учитывая простоту VBA-решения Саймона; Я нашел в основном тот же код на форумах MrExcel (mrexcel.com/forum/showthread.php?t=376733).
 PowerUser01 окт. 2010 г., 21:16
(Небольшой обучающий совет: в VBA есть функция Intellisense, которая дает вам список доступных методов / свойств / и т. Д. В VBA, если вы наберете «PPSlide». Вы должны увидеть раскрывающийся список членов этого класса. Если вы не видите, что ищете, значит, вы делаете это неправильно. Очень полезно, когда вы создаете что-то, чего никогда не делали раньше)
 iper01 окт. 2010 г., 19:05
Ошибка компиляции: метод или элемент данных не найден Является ли ошибка, которую я получаю при попытке PPSlide.Selection.PasteExcelTable или PPSlide.Shapes.PasteExcelTable. Так что я думаю, что синтаксис не все хорошо тогда?
 iper01 окт. 2010 г., 17:20
Я пробовал PPSlide.Selection.PasteExcelTable - но это не работает. а также PPSlide.Shapes.PasteExcelTable. Есть идеи? РЕДАКТИРОВАТЬ: я не могу записать макросы в PowerPoint, но когда я пытаюсь сделать это в слове и скопировать таблицу из Excel, как вы предлагаете мне получить этот код: Selection.PasteAndFormat (wdTableOriginalFormatting) - есть ли что-то подобное, я могу использовать в PowerPoint код VBA?
 iper02 окт. 2010 г., 01:15
Спасибо за альтернативное решение. Но я не могу заставить его работать. Это происходит главным образом потому, что мой документ Excel, на который я пытаюсь сослаться, пуст и содержит макрос для запуска при событии открытия, которое динамически создает содержимое из внешнего источника XML и документ никогда не сохраняется. Хотелось бы, чтобы был более легкий подход к этой проблеме, но, похоже, мне, возможно, придется попытаться настроить свои макросы, чтобы заставить его работать таким образом, если ни у кого больше нет других решений. Спасибо за помощь, очень ценю это!
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

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

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

Application.CommandBars.ExecuteMso ("PasteSourceFormatting")

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

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

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
 Mowgli19 авг. 2013 г., 17:12
Можете ли вы объяснить это, пожалуйста? Я не могу заставить эту Макро работать.

Ваш ответ на вопрос