如何将单个或所有图表从Excel工作表导出到PowerPoint？

Sub SingleActiveChartToPowerPoint_EarlyBinding1() Updated by Extendoffice 2017/9/15 Dim pptApp As PowerPoint.Application Dim pptPres As PowerPoint.Presentation Dim pptSlide As PowerPoint.Slide Dim pptShape As PowerPoint.Shape Dim pptShpRng As PowerPoint.ShapeRange Dim xActiveSlideNow As Long On Error Resume Next If ActiveChart Is Nothing Then MsgBox "Select a chart and try again!", vbExclamation, "KuTools For Excel" Exit Sub End If Set pptApp = GetObject(, "PowerPoint.Application") If pptApp Is Nothing Then Set pptApp = CreateObject("PowerPoint.Application") Set pptPres = pptApp.Presentations.Add Set pptSlide = pptPres.Slides.Add(1, ppLayoutBlank) Else If pptApp.Presentations.Count > 0 Then Set pptPres = pptApp.ActivePresentation If pptPres.Slides.Count > 0 Then xActiveSlideNow = pptApp.ActiveWindow.View.Slide.SlideIndex Set pptSlide = pptPres.Slides(xActiveSlideNow) Else Set pptSlide = pptPres.Slides.Add(1, ppLayoutBlank) End If Else Set pptPres = pptApp.Presentations.Add Set pptSlide = pptPres.Slides.Add(1, ppLayoutBlank) End If End If ActiveChart.ChartArea.Copy With pptSlide .Shapes.Paste Set pptShape = .Shapes(.Shapes.Count) Set pptShpRng = .Shapes.Range(pptShape.Name) End With With pptShpRng .Align msoAlignCenters, True .Align msoAlignMiddles, True End With pptShpRng.Select End Sub

Option Explicit Updated by Extendoffice 2017/9/15 Dim pptApp As PowerPoint.Application Dim pptPres As PowerPoint.Presentation Dim pptSlide As PowerPoint.Slide Dim pptSlideCount As Integer Sub ChartsToPowerPoint() Dim xSheet As Worksheet Dim xChartsCount As Integer Dim xChart As Object Dim xActiveSlideNow As Integer On Error Resume Next For Each xSheet In ActiveWorkbook.Worksheets xChartsCount = xChartsCount + xSheet.ChartObjects.Count Next xSheet If xChartsCount = 0 Then MsgBox "Sorry, there are no charts to export!", vbCritical, "Ops" Exit Sub End If Set pptApp = GetObject(, "PowerPoint.Application") If pptApp Is Nothing Then Set pptApp = CreateObject("PowerPoint.Application") Set pptPres = pptApp.Presentations.Add Set pptSlide = pptPres.Slides.Add(1, ppLayoutBlank) Else If pptApp.Presentations.Count > 0 Then Set pptPres = pptApp.ActivePresentation If pptPres.Slides.Count > 0 Then xActiveSlideNow = pptApp.ActiveWindow.View.Slide.SlideIndex Set pptSlide = pptPres.Slides(xActiveSlideNow) Else Set pptSlide = pptPres.Slides.Add(1, ppLayoutBlank) End If Else Set pptPres = pptApp.Presentations.Add Set pptSlide = pptPres.Slides.Add(1, ppLayoutBlank) End If End If For Each xSheet In ActiveWorkbook.Worksheets For Each xChart In xSheet.ChartObjects Call pptFormat(xChart.Chart) Next xChart Next xSheet For Each xChart In ActiveWorkbook.Charts Call pptFormat(xChart) Next xChart Set pptSlide = Nothing Set pptPres = Nothing Set pptApp = Nothing MsgBox "The charts were copied successfully to the new presentation!", vbInformation, "KuTools For Excel" End Sub Private Sub pptFormat(xChart As Chart) Dim xCharTiTle As String Dim I As Integer On Error Resume Next xCharTiTle = xChart.ChartTitle.Text xChart.ChartArea.Copy pptSlideCount = pptPres.Slides.Count Set pptSlide = pptPres.Slides.Add(pptSlideCount + 1, ppLayoutBlank) pptSlide.Select pptSlide.Shapes.PasteSpecial ppPasteJPG If xCharTiTle <> "" Then pptSlide.Shapes.AddTextbox msoTextOrientationHorizontal, 12.5, 20, 694.75, 55.25 End If For I = 1 To pptSlide.Shapes.Count With pptSlide.Shapes(I) Select Case .Type Case msoPicture: .Top = 87.84976 .left = 33.98417 .Height = 422.7964 .Width = 646.5262 Case msoTextBox: With .TextFrame.TextRange .ParagraphFormat.Alignment = ppAlignCenter .Text = xCharTiTle .Font.Name = "Tahoma (Headings)" .Font.Size = 28 .Font.Bold = msoTrue End With End Select End With Next I End Sub

最佳办公生产力工具

在Word，Excel，PowerPoint中启用选项卡式编辑和阅读，发布者，Access，Visio和Project。 在同一窗口的新选项卡中而不是在新窗口中打开并创建多个文档。 每天将您的工作效率提高50％，并减少数百次鼠标单击！