使用 VBA 将 Excel 图表粘贴到 PPT 时嵌入单个工作表

编程问答 2022-05-02

问题描述

我一直致力于通过 VBA 将可编辑图表从 Excel 工作簿自动复制到 PowerPoint 演示文稿。我通过此链接 Using VBA to Paste Excel Chart with Data into PowerPoint 获得了很多帮助，该链接对复制粘贴位进行了排序。

Sub copyChartSlide2()
Application.ScreenUpdating = False
   
   
  Dim newPowerPoint As PowerPoint.Application
  Dim activeSlide As PowerPoint.Slide
  Dim cht1 As Excel.ChartObject
  Dim Data As Excel.Worksheet
  Dim pptcht1 As PowerPoint.Shape
  Dim iLoopLimit As Long
  Dim OpenPptDialogBox As Object
  Dim SlideIndex As Long
 

  Application.ScreenUpdating = False

  'Look for existing instance
 
     
     Set newPowerPoint = CreateObject("PowerPoint.Application")
   Set OpenPptDialogBox = newPowerPoint.FileDialog(msoFileDialogopen)
   If OpenPptDialogBox.Show = -1 Then
    newPowerPoint.Presentations.Open (OpenPptDialogBox.SelectedItems(1))
    End If
        
    Set activeSlide = newPowerPoint.ActivePresentation.Slides(1)
       
    SlideIndex = 1

  Set Data = Worksheets("Slide2")

  Set cht1 = Data.ChartObjects("Chart1")
 
  cht1.copy

  newPowerPoint.CommandBars.ExecuteMso "PasteExcelChartDestinationTheme"

  DoEvents

  On Error Resume Next
  Do
    DoEvents
    Set pptcht1 = activeSlide.Shapes(activeSlide.Shapes.Count)
    If Not pptcht1 Is nothing Then Exit Do
    iLoopLimit = iLoopLimit + 1
    If iLoopLimit > 100 Then Exit Do
  Loop
  On Error GoTo 0

  Debug.Print "iLoopLimit = " & iLoopLimit

  With pptcht1
    .Left = 103.68
    .Top = 84.24
  End With

  iLoopLimit = 0
 
  AppActivate newPowerPoint.Caption
  Set activeSlide = nothing
  Set newPowerPoint = nothing

Application.ScreenUpdating = True

End Sub

但是，当图表被粘贴时，它会嵌入整个工作簿，而不仅仅是工作表。由于我正在处理一个大约 20 页的工作簿，每次将图表粘贴到演示文稿中时，整个工作簿都会被嵌入，并且由于图表很多，这使得 PPT 很重，并且使过程非常缓慢。有没有办法只嵌入与图表相关的工作表？

解决方法

暂无找到可以解决该程序问题的有效方法，小编努力寻找整理中！

如果你已经找到好的解决方法，欢迎将解决方案带上本链接一起发送给小编。

小编邮箱:dio#foxmail.com (将#修改为@）

excelexcelexcel-2010powerpointpowerpointvba