Вставить таблицу Excel в Powerpoint, просто вставив диапазон в использовании VBA

Question

У меня есть код VBA, который успешно копирует диапазон из Excel в слайд-два новой презентации на основе шаблона (VBA открывает Powerpoint).

Макрос заканчивается путем вставки диаграммы в слайд-двое из листа в Excel. Теперь я хочу вернуться на этот рабочий лист, скопировать диаграмму, которая уже была построена из этих данных, и вставить ее в тот же слайд, который только что вставляли данные.

Мой код

'Plots Chart Based on Tabular Data 
Range("A1:B1").Select 
Range(Selection, Selection.End(xlDown)).Select 
ActiveSheet.Shapes.AddChart2(201, xlColumnClustered).Select 
ActiveChart.ApplyChartTemplate (_ 
     "C:\Users\Colin\AppData\Roaming\Microsoft\Templates\Charts\Edge45 Bar Chart Transparent Horizontal Bars.crtx") 
ActiveChart.SetSourceData Source:=Range("'Screaming Frog Summary'!$A$1:$B$16") 
ActiveSheet.Shapes("Chart 1").IncrementLeft -57.6 
ActiveSheet.Shapes("Chart 1").IncrementTop 243.9 

'Opens a new PowerPoint presentation based on template and pastes data into Slide 2 of Powerpoint from Excel 

Dim PPApp As PowerPoint.Application, PPPres As PowerPoint.Presentation, PPSlide As PowerPoint.Slide, PPShape As Object 
Dim XLws As Worksheet 

Set XLws = ActiveSheet 
Set PPApp = New PowerPoint.Application 
Set PPPres = PPApp.Presentations.Open("C:\Users\Colin\Dropbox (Edge45)\Edge45 Team Folder\Edge45 Company Documents\Templates\Powerpoint Templates\Edge45 Audit Template Macro.potm", Untitled:=msoTrue) 
PPApp.Visible = True 
Set PPSlide = PPPres.Slides(2) 

XLws.Range("A1:D16").Copy 
Set PPShape = PPSlide.Shapes.PasteSpecial(DataType:=ppPasteHTML, Link:=msoFalse) 
Application.CutCopyMode = False 

With PPShape 
    .Top = 10 
    .Height = 100 
    .Left = 10 
    .Width = 100 
End With 

Answer 1

Я не знаю, сколько карт у вас есть на исходном листе, но при условии, что это только один, если добавить эти строки в конце кода будет копировать и вставить первую диаграмму из вашего ссылочного листа вашего второго слайда:

XLws.ChartObjects(1).Copy ' or XLws.ChartObjects("Chart 1").Copy 
Set PPChart = PPSlide.Shapes.PasteSpecial (ppPasteDefault) 

Обратите внимание, что если целевой слайд имеет пустую таблицу и/или объекты заполнители, диаграмма может быть автоматически вставлена ​​в целевом заполнитель, если вы выбираете его первым с чем-то вроде этого:

PPSlide.Shapes.Placeholders(2).Select 

Индекс 2, возможно, потребуется изменить в зависимости от макета слайда.

Вы можете переместить диаграмму, как это:

With PPChart 
    .Top = 10 
    .Height = 100 
    .Left = 10 
    .Width = 100 
End With 

Answer 2

Это не полностью протестирована (как у меня нет Excel 2013), так что я не могу проверить AddChart2, но аналогичный код с графиками работы с 2010

Позвольте мне знать, если вы получаете сообщение об ошибке на следующей строке: Set Cht = XLws.Shapes.AddChart2(201, xlColumnClustered).Chart

Код

Option Explicit 

Sub ExportToPPT() 

Dim PPApp As PowerPoint.Application 
Dim PPPres As PowerPoint.Presentation 
Dim PPSlide As PowerPoint.Slide 
Dim PPShape As Object, PPChart As Object 

Dim XLws As Worksheet 
Dim Cht As Chart 

Set XLws = ActiveSheet 

'Plots Chart Based on Tabular Data 
XLws.Range(Range("A1:B1"), Range("A1:B1").End(xlDown)).Select 

Set Cht = XLws.Shapes.AddChart2(201, xlColumnClustered).Chart 

With Cht 
    .ApplyChartTemplate ("C:\Users\Colin\AppData\Roaming\Microsoft\Templates\Charts\Edge45 Bar Chart Transparent Horizontal Bars.crtx") 
    .SetSourceData Source:=Range("'Screaming Frog Summary'!$A$1:$B$16") 
    .Shapes("Chart 1").IncrementLeft -57.6 
    .Shapes("Chart 1").IncrementTop 243.9 
End With 

'Opens a new PowerPoint presentation based on template and pastes data into Slide 2 of Powerpoint from Excel 
Set PPApp = New PowerPoint.Application 
Set PPPres = PPApp.Presentations.Open("C:\Users\Colin\Dropbox (Edge45)\Edge45 Team Folder\Edge45 Company Documents\Templates\Powerpoint Templates\Edge45 Audit Template Macro.potm", Untitled:=msoTrue) 
PPApp.Visible = True 
Set PPSlide = PPPres.Slides(2) 

XLws.Range("A1:D16").Copy 
Set PPShape = PPSlide.Shapes.PasteSpecial(DataType:=ppPasteHTML, Link:=msoFalse) 
Application.CutCopyMode = False 

With PPShape 
    .Top = 10 
    .Height = 100 
    .Left = 10 
    .Width = 100 
End With 

Cht.ChartArea.Copy '<-- copy the Chart 
Set PPChart = PPSlide.Shapes.PasteSpecial(ppPasteDefault, msoFalse) 'ppPasteShape 


End Sub 

Answer 3

Вы можете использовать другой тип PasteSpecial, просто выберите тот, который вы предпочитаете:

Я установил 2 способа разместить вставленную форму, так что вы можете установить его легко!

Sub test_Superhans() 
    Dim PPApp As PowerPoint.Application, PPPres As PowerPoint.Presentation, PPSlide As PowerPoint.Slide, PPShape As Object 
    Dim wS As Excel.Worksheet, Rg As Excel.Range, oCh As Object 

    'Opens a new PowerPoint presentation based on template 
    Set PPApp = New PowerPoint.Application 
     PPApp.Visible = True 
    Set PPPres = PPApp.Presentations.Open(_ 
      "C:\Users\Colin\Dropbox (Edge45)\Edge45 Team Folder\Edge45 Company Documents\Templates\Powerpoint Templates\Edge45 Audit Template Macro.potm", _ 
      Untitled:=msoTrue) 
    Set PPSlide = PPPres.Slides(2) 

    'Set the sheet where the data is 
    Set wS = ThisWorkbook.Sheets("Screaming Frog Summary") 
    With wS 
     Set Rg = .Range("A1:B" & .Range("A" & .Rows.Count).End(xlUp).Row) 
     Set oCh = .Shapes.AddChart2(201, xlColumnClustered) 
    End With 'wS 

    With oCh 
     .ApplyChartTemplate (_ 
      "C:\Users\Colin\AppData\Roaming\Microsoft\Templates\Charts\Edge45 Bar Chart Transparent Horizontal Bars.crtx") 
     .SetSourceData Source:=Rg 
     .Copy 
    End With 'oCh 

    'Paste and place the chart 
    ''Possibles DataType : see the image! ;) 
    Set PPShape = PPSlide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile, Link:=msoFalse) 
    Application.CutCopyMode = False 
    With PPShape 
     .Height = 100 
     'Place from bottom using : PPPres.PageSetup.SlideHeigth - .Height 
     .Top = PPPres.PageSetup.SlideHeigth - .Height - 10 
     .Width = 100 
     'Place from right using : PPPres.PageSetup.SlideWidth - .Width 
     .Left = PPPres.PageSetup.SlideWidth - .Width - 10 
    End With 

    'Copy the data 
    Rg.Copy 
    Set PPShape = PPSlide.Shapes.PasteSpecial(DataType:=ppPasteHTML, Link:=msoFalse) 
    Application.CutCopyMode = False 
    With PPShape 
     .Height = 100 
     'Place from top 
     .Top = 10 
     .Width = 100 
     'Place from left 
     .Left = 10 
    End With 
End Sub