pptvba复制工作表中的超级表到ppt

lss001

Private Sub CommandButton1_Click()
    Dim objSlide As Slide, objLayout As CustomLayout
    Dim objExcel As Object, objWorkbook As Object
    Dim lngIndex As Long
    Dim strFilename As String
   
    ph = ActivePresentation.Path &  "\" '指定文件夹
    Set objExcel = CreateObject("Excel.Application")
    lngIndex = 1
    Set objLayout = ActivePresentation.Slides(lngIndex).CustomLayout
    strFilename = Dir$(ph & "*.xls*")

    Do Until strFilename = vbNullString '循环
        lngIndex = lngIndex + 1 '累加
        Set objWorkbook = objExcel.Workbooks.Open(ph & strFilename) '打开Excel
        Call objWorkbook.Worksheets("Tabelle1").Range("D1:Q28").Copy '复制超级表区域
        Set objSlide = ActivePresentation.Slides.AddSlide(lngIndex, objLayout) '添加幻灯片
        Call objSlide.Shapes.Paste '粘贴
        Call objWorkbook.Close(SaveChanges:=False) '关闭
        strFilename = Dir$
    Loop

    Call objExcel.Quit '释放对象
    Set objSlide = Nothing
    Set objLayout = Nothing
    Set objWorkbook = Nothing
    Set objExcel = Nothing
End Sub