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

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论坛，供有兴趣的朋友参考。

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