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

我试图创建一个Excel宏，它复制在Excel表格上显示的图表，并将它们粘贴到PowerPoint中（粘贴特殊）。我遇到的问题是如何将每张图表粘贴到不同的幻灯片上？我不知道语法所有..使用VBA将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

来源

2011-09-20 thedeepfield

由于我没有你的文件位置工作与我已附加低于

创建的PowerPoint的新实例的例程（后期绑定，因此需要以限定用于ppViewSlide等常数）通过每个图表中的一个称为Chart1片
路（按你例如）
添加一个新的幻灯片
粘贴在每个排行榜中，然后重复

你需要为出口规模前，每个排行榜中的图片格式，也可以更改默认图表大小？

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

来源

2011-09-20 23:30:09 brettdj

+1但是，为什么不早期绑定？ –

Thx Jean-Francois。这是一个公平的问题 - 简短的答案是个人偏好。通常我会延迟绑定，如果自动化的对象的多个版本是可能的，正如我发现用户在问答论坛可以与参考设置斗争。尽管我在重复主插件中使用了早期版本，因为它只绑定到文件脚本库，所以它可以减少运行时间的20％到30％，并且作为插件的一部分，它会自动为用户安装。 – brettdj

与功能代码从Excel中绘制图表6的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

来源

2016-01-09 21:05:11

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

回答

相关问题