将所有表格和图表从所有 Excel 工作表复制到 PowerPoint

Question

我需要代码 sn-p 使用 Excel 中的宏 (VBA) 将所有图表从 Excel 文件中的所有工作表复制到 PowerPoint 文件中。

以下代码仅复制图表。我想复制所有表格、图表和图像。

Sub PushChartsToPPT()
 'Set reference to 'Microsoft PowerPoint 12.0 Object Library'
 'in the VBE via Tools > References...
 '
 Dim ppt As PowerPoint.Application
 Dim pptPres As PowerPoint.Presentation
 Dim pptSld As PowerPoint.Slide
 Dim pptCL As PowerPoint.CustomLayout
 Dim pptShp As PowerPoint.Shape

 Dim cht As Chart
 Dim ws As Worksheet
 Dim i As Long

 'Get the PowerPoint Application object:
 Set ppt = CreateObject("PowerPoint.Application")
 ppt.Visible = msoTrue
 Set pptPres = ppt.Presentations.Add

 'Get a Custom Layout:
 For Each pptCL In pptPres.SlideMaster.CustomLayouts
     If pptCL.Name = "Title and Content" Then Exit For
 Next pptCL

 'Copy ALL charts in Chart Sheets:
 For Each cht In ActiveWorkbook.Charts
     Set pptSld = pptPres.Slides.AddSlide(pptPres.Slides.Count + 1, pptCL)
     pptSld.Select

    For Each pptShp In pptSld.Shapes.Placeholders
         If pptShp.PlaceholderFormat.Type = ppPlaceholderObject Then Exit For
     Next pptShp
     If pptShp Is Nothing Then Stop

     cht.ChartArea.Copy
     ppt.Activate
     pptShp.Select
     ppt.Windows(1).View.Paste
 Next cht

 'Copy ALL charts embedded in EACH WorkSheet:
 For Each ws In ActiveWorkbook.Worksheets
     For i = 1 To ws.ChartObjects.Count
         Set pptSld = pptPres.Slides.AddSlide(pptPres.Slides.Count + 1, pptCL)
         pptSld.Select

         For Each pptShp In pptSld.Shapes.Placeholders
             If pptShp.PlaceholderFormat.Type = ppPlaceholderObject Then Exit For
         Next pptShp

        Set cht = ws.ChartObjects(i).Chart
         cht.ChartArea.Copy
         ppt.Activate
         pptShp.Select
         ppt.Windows(1).View.Paste
     Next i
   Next ws
 End Sub

Answer 1

对于图片，请尝试使用来自How to select pictures的形状

Dim Pic As Shape
For Each Pic In ActiveSheet.Shapes
    If Pic.Type = msoPicture Then
        Pic.Select
        'do something with image
    End If
Next Pic