Вставьте таблицу Excel в Powerpoint с помощью VBA - PullRequest
Новая
       21

Вставьте таблицу Excel в Powerpoint с помощью VBA

8 голосов
/ 21 сентября 2011

Я пытаюсь создать макрос Excel, который копирует диаграммы, отображаемые на листе Excel, и вставляет их (специальные вставки) в PowerPoint. У меня проблема в том, как вставить каждую диаграмму на другой слайд? Я вообще не знаю синтаксис ..

Это то, что у меня есть (работает, но вставляется только на первый лист): 

Sub graphics3()

Sheets("Chart1").Select
ActiveSheet.ChartObjects("Chart1").Activate
ActiveChart.ChartArea.Copy
Sheets("Graphs").Select
range("A1").Select
ActiveSheet.Paste
     With ActiveChart.Parent
     .Height = 425 ' resize
     .Width = 645  ' resize
     .Top = 1    ' reposition
     .Left = 1   ' reposition
 End With

Dim PPT As Object
Set PPT = CreateObject("PowerPoint.Application")
PPT.Visible = True
PPT.Presentations.Open Filename:="locationwherepptxis"

Set PPApp = GetObject("Powerpoint.Application")
Set PPPres = PPApp.activepresentation
Set PPSlide = PPPres.slides _
    (PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)

' Copy chart as a picture
ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, _
    Format:=xlPicture

' Paste chart
PPSlide.Shapes.Paste.Select

' Align pasted chart
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True

Ответы [ 2 ]

8 голосов
/ 21 сентября 2011

Учитывая, что у меня нет мест для работы с файлами, я добавил нижеприведенную подпрограмму

  1. Создан новый экземпляр PowerPoint (позднее связывание, отсюда необходимость определения констант для ppViewSlide и т. Д.)
  2. Прокручивает каждую диаграмму на листе с именем Chart1 (согласно вашему примеру)
  3. Добавляет новый слайд
  4. Вставляет каждую диаграмму, затем повторяет

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

Const ppLayoutBlank = 2
Const ppViewSlide = 1

Sub ExportChartstoPowerPoint()
    Dim PPApp As Object
    Dim chr
    Set PPApp = CreateObject("PowerPoint.Application")
    PPApp.Presentations.Add
    PPApp.ActiveWindow.ViewType = ppViewSlide
    For Each chr In Sheets("Chart1").ChartObjects
        PPApp.ActivePresentation.Slides.Add PPApp.ActivePresentation.Slides.Count + 1, ppLayoutBlank
        PPApp.ActiveWindow.View.GotoSlide PPApp.ActivePresentation.Slides.Count
        chr.Select
        ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
        PPApp.ActiveWindow.View.Paste
        PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
        PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
    Next chr
    PPApp.Visible = True
End Sub
3 голосов
/ 10 января 2016

Код с функцией построения 6 графиков из Excel в PPT 

Option Base 1
Public ppApp As PowerPoint.Application

Sub CopyChart()

Dim wb As Workbook, ws As Worksheet
Dim oPPTPres As PowerPoint.Presentation
Dim myPPT As String
myPPT = "C:\LearnPPT\MyPresentation2.pptx"

Set ppApp = CreateObject("PowerPoint.Application")
'Set oPPTPres = ppApp.Presentations("MyPresentation2.pptx")
Set oPPTPres = ppApp.Presentations.Open(Filename:=myPPT)
ppApp.Visible = True
Set wb = ThisWorkbook
Set ws = wb.Sheets(1)

i = 1

For Each shp In ws.Shapes

    strShapename = "C" & i
    ws.Shapes(shp.Name).Name = strShapename
    'shpArray.Add (shp)
    i = i + 1

Next shp

Call Plot6Chart(oPPTPres, 2, ws.Shapes(1), ws.Shapes(2), ws.Shapes(3), ws.Shapes(4), ws.Shapes(5), ws.Shapes(6))

End Sub
Function Plot6Chart(pPres As Presentation, SlideNo As Long, ParamArray cCharts())

Dim oSh As Shape
Dim pSlide As Slide
Dim lLeft As Long, lTop As Long

Application.CutCopyMode = False
Set pSlide = pPres.Slides(SlideNo)

For i = 0 To UBound(cCharts)

    cCharts(i).Copy
    ppApp.ActiveWindow.View.GotoSlide SlideNo
    pSlide.Shapes.Paste
    Application.CutCopyMode = False


    If i = 0 Then ' 1st Chart
        lTop = 0
        lLeft = 0
    ElseIf i = 1 Then ' 2ndChart
        lLeft = lLeft + 240
    ElseIf i = 2 Then ' 3rd Chart
        lLeft = lLeft + 240
    ElseIf i = 3 Then ' 4th Chart
        lTop = lTop + 270
        lLeft = 0
    ElseIf i = 4 Then ' 5th Chart
        lLeft = lLeft + 240
    ElseIf i = 5 Then ' 6th Chart
        lLeft = lLeft + 240
    End If

    pSlide.Shapes(cCharts(i).Name).Left = lLeft
    pSlide.Shapes(cCharts(i).Name).Top = lTop

Next i

Set oSh = Nothing
Set pSlide = Nothing
Set oPPTPres = Nothing
Set ppApp = Nothing
Set pPres = Nothing

End Function
...