问与答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社群，进行技术交流和提问，获取更多电子资料。