问与答118：如何使用VBA将多个工作表数据复制到PPT中？

excelperfect

Q：我需要编写一个程序来实现下面的目的。

遍历每个工作表，如果工作表的单元格S1中的值为“1”，则将该工作表的“Print_Area”（打印区域）复制并粘贴到一张空白幻灯片中。

A：可以使用下面的VBA代码实现。

Sub CopyExcelRangeToPowerPoint()

    Dim rng As Range

    Dim PowerPointApp As Object

    Dim myPresentation As Object

    Dim mySlide As Object

    Dim myShape As Object

    Dim ws As Worksheet

    Dim x As Integer

    x = 0

   '从Excel中复制的单元格区域

    Set rng =ThisWorkbook.ActiveSheet.Range('Print_Area')

   '创建PowerPoint实例

    On Error Resume Next

   '如果PowerPoint已打开?

    Set PowerPointApp =GetObject(class:='PowerPoint.Application')

   '清除错误

    Err.Clear

   '如果PowerPoint还没有打开则打开PowerPoint

    If PowerPointApp Is Nothing Then SetPowerPointApp = CreateObject(class:='PowerPoint.Application')

   '处理PowerPoint应用程序没有发现的情形

    If Err.Number = 429 Then

        MsgBox '没有发现PowerPoint, 程序中止.'

        Exit Sub

    End If

    On Error GoTo 0

   '优化

    Application.ScreenUpdating = False

   '创建新演示

    Set myPresentation =PowerPointApp.Presentations.Add

   '遍历Excel工作表,粘贴到PowerPoint

    For Each ws In ActiveWorkbook.Worksheets

        If ws.Range('S1') ='1' Then

            '从Excel中复制单元格区域

            Set rng =ThisWorkbook.ActiveSheet.Range('Print_Area')

            x = x + 1

            '添加幻灯片

            Set mySlide =myPresentation.Slides.Add(x, 12) '11 =ppLayoutTitleOnly, 12 空白

            rng.Copy

            '粘贴到PowerPoint

            mySlide.Shapes.PasteSpecialDataType:=10 '2 = ppPasteEnhancedMetafile

            Set myShape =mySlide.Shapes(mySlide.Shapes.Count)

            '设置位置:

            myShape.Left = 15

            myShape.Top = 15

            myShape.Width = 690

        End If

    Next ws

   '使PowerPoint可见并激活

    PowerPointApp.Visible = True

    PowerPointApp.Activate

   '清除剪贴板

    Application.CutCopyMode = False

End Sub

小结：又一个Excel与PowerPoint整合应用的示例，注意添加新幻灯片的代码技巧。

注：今天的问题整理自mrexcel.com论坛，供有兴趣的朋友参考。

欢迎在下面留言，完善本文内容，让更多的人学到更完美的知识。

欢迎到知识星球：完美Excel社群，进行技术交流和提问，获取更多电子资料。