VBA根据Excel内容快速创建PPT

快速创建PPT"/>

VBA根据Excel内容快速创建PPT

示例需求：根据Excel中选中的单元格内容（3列）如下图所示，在已打卡的PowerPoint文件中创建页面。

新增PPT Slide页面使用第二个模板页面，其中包含两个文本占位符，和一个图片占位符。将Excel选中区域中前两列写入文字占位符，第3列图片粘贴至图片占位符。

示例代码如下。

Sub Excel2PPT()Dim xlDataRow As RangeDim pptApp As PowerPoint.ApplicationDim pptPres As PowerPoint.PresentationDim pptSld As PowerPoint.SlideDim objDic As ObjectDim xlShp As Shape, i As IntegerDim sCellAddress As StringSet pptApp = GetObject(, "PowerPoint.Application")Set pptPres = pptApp.ActivePresentationIf TypeName(Selection) = "Range" ThenSet objDic = CreateObject("scripting.dictionary")For i = 1 To ActiveSheet.Shapes.CountSet xlShp = ActiveSheet.Shapes(i)If Not Application.Intersect(xlShp.TopLeftCell, Selection) Is Nothing ThenSet objDic(xlShp.TopLeftCell.Address) = xlShpEnd IfNextFor Each xlDataRow In Selection.RowsSet pptSld = pptPres.Slides.AddSlide(pptPres.Slides.Count + 1, pptPres.SlideMaster.CustomLayouts(2))pptSld.SelectWith pptSld.Shapes.Placeholders(1).TextFrame.TextRange.Text = xlDataRow.Cells(1, 1).Placeholders(2).TextFrame.TextRange.Text = xlDataRow.Cells(1, 2)sCellAddress = xlDataRow.Cells(1, 3).AddressIf objDic.exists(sCellAddress) ThenobjDic(sCellAddress).Copy.Placeholders(3).Select.PasteSpecial DataType:=ppPasteMetafilePictureEnd IfEnd WithNext xlDataRowEnd If
End Sub

【代码解析】
第9行代码获取PowerPoint应用程序。
第10行代码获取PowerPoint应用程序中活动Presentation对象。
第11行代码判断Excel中Selection是否为Range对象，如果选中了其他对象（例如Shape对象），后续代码会产生运行时错误。
第12行代码创建字典对象。
第13~18行代码循环遍历活动工作表中的Shape对象，将选中区域中的Shape对象保存在字典对象中。
第14行代码获取Shape对象。
第15行代码判断Shape对象的锚点单元格（即左上角单元格）是否在选中区域中。
如果满足条件，第16行代码将Shape对象保存在字典对象中，其中锚点单元格的引用地址作为字典的键（Key）。
第19~32行代码循环遍历选中区域的数据行。
第20行代码根据第2个模板页面创建一个新的Slide页面。
第21行代码选中新增的页面。
第23行代码将选中区域中第一列内容写入第一个占位符（Placeholder）中。
第24行代码将选中区域中第2列内容写入第2个占位符（Placeholder）中。
第25行代码获取第3列的单元格引用地址。
第26行代码判断第3列的单元格引用地址是否存在于字典的键中，如果不存在，说明该单元格中没有Shape对象。
如果存在，第24行代码拷贝该单元格中的Shape对象。
第28行代码选中图片占位符。
第29行代码粘贴图片。

运行代码效果如下图所示。

微软在线文档:

Shapes.PasteSpecial method (PowerPoint)