如何將單個或所有圖表從Excel工作表導(dǎo)出到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

最佳辦公生產(chǎn)力工具

在Word，Excel，PowerPoint中啟用選項卡式編輯和閱讀，發(fā)布者，Access，Visio和Project。 在同一窗口的新選項卡中而不是在新窗口中打開并創(chuàng)建多個文檔。 每天將您的工作效率提高50％，并減少數(shù)百次鼠標(biāo)單擊！