使用VBA将Excel图表粘贴到PPT时嵌入单页

我一直致力于通过VBA将可编辑图表从excel工作簿自动复制到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变得沉重，并且使过程非常缓慢。有没有办法只嵌入与图表相关的工作表？

图表是否需要是可编辑的图表，或者您可以使用

CopyAsPicture

将图表图像放入PowerPoint？如果没有，您可能需要创建一个宏来将图表和工作表提取到临时工作簿中，并嵌入该工作簿。否，它需要是一个可编辑的图表