使用VBA将Excel图表粘贴到Powerpoint中

时间:2011-09-20 22:22:49

标签: excel vba powerpoint paste

我正在尝试创建一个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 个答案:

答案 0 :(得分:7)

鉴于我没有你的文件位置,我已经附加了一个例程

  1. 创建了一个新的PowerPoint实例(后期绑定,因此需要为ppViewSlide定义常量等)
  2. 循环遍历名为Chart1的表格中的每个图表(根据您的示例)
  3. 添加新幻灯片
  4. 粘贴每个图表,然后重复
  5. 在导出尺寸之前,您是否需要格式化每个图表图片,还是可以更改默认图表尺寸?

    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
    

答案 1 :(得分:2)

具有从Excel到PPT绘制6个图表的功能的代码

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