Question

我需要使用代码段将所有图表的Excel文件中的所有图表和表格复制到Excel文件中使用宏（VBA）。

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

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

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

1 个答案: