VBA利用Eccel数据表自动生成PPT方案

在手头工作中遇到了一件工作量极大,但没什么技术含量的任务。手工复制粘贴,耗时耗力,预计花费大量时间和精力。因为ppt方案皆由Ecxel数据生成,故想到是否可借助office的VBA功能,来自动填充内容。
VBA早有耳闻,但从未实践过。网上搜索相关内容,亦可以看出有较多人对此内容颇有关注。既然有理论基础,那就不妨一试。磨刀不误砍柴工。
先介绍一下项目情况。每个项目由两页ppt组成,一页是其项目内容的介绍,包括文字、图、表等,另一页是一个标准的流程图,每个项目均相同,不同的是页码、项目编号、标题等不同。
首先制作一个母版,作为该ppt的核心模板。为正反不同的对称页面。

qq%e6%88%aa%e5%9b%be20160919112259

然后制作一个标准的页面,包含其中所要填写的内容的样式。第1页中的项目概况、项目计划、项目进展等均由excel生成,项目位置因需要人工判断,过于复杂,仍需要人工进行标注。第2页中,需要更改的仅为标题内容。

qq%e6%88%aa%e5%9b%be20160919112007 qq%e6%88%aa%e5%9b%be20160919112128

制作好模板后,如何进行操作呢?
我的逻辑是:先打开excel表取出我们要的数据,对第1页、第2页进行修改、填充。然后复制第1页、第2页,粘贴为第3页、第4页,然后继续取出数据进行修改、填充,如此循环复制,直到300余个项目均复制、粘贴完成,关闭excel表,清除缓存。

打开数据表:
Dim MyexcelApp As New Excel.Application
Dim MyexcelBook As New Excel.Workbook
Dim MyexcelSheet As New Excel.Worksheet
Pathstr = "E:\……\test.xls"
Set MyexcelBook = MyexcelApp.Workbooks.Open(Pathstr)
Set MyexcelSheet = MyexcelBook.Worksheets(1)
MyexcelSheet.Activate

为了操作方便,给ppt里面的多边形、表格或者文本框等重命名,如下:

qq%e6%88%aa%e5%9b%be20160919130416

加一个for循环,更新数据并复制粘贴:
For i = 2 To 300
'项目概况
ActivePresentation.Slides(i).Shapes("XMTextBox").TextFrame.TextRange.Text = "项目名称:" +
MyexcelSheet.Range("B" & (i + 6)).Value & Chr(13) & "责任单位:" +
MyexcelSheet.Range("C" & (i + 6)).Value & Chr(13) & "规划范围:" +
MyexcelSheet.Range("D" & (i + 6)).Value & Chr(13) & "建设内容与规模:" +
MyexcelSheet.Range("E" & (i + 6)).Value
'项目名称
ActivePresentation.Slides(i).Shapes("TitleTextBox").TextFrame.TextRange.Text =
MyexcelSheet.Range("B" & (i + 6)).Value
ActivePresentation.Slides(i).Shapes("PlanTable").Table.Cell(3, 1).Shape.TextFrame.TextRange.Text =
MyexcelSheet.Range("B" & (i + 6)).Value
'项目编号
ActivePresentation.Slides(i).Shapes("IndexTextBox").TextFrame.TextRange.Text =
MyexcelSheet.Range("A" & (i + 6)).Value
'当前进度
ActivePresentation.Slides(i).Shapes("PlanTable").Table.Cell(3, 3).Shape.TextFrame.TextRange.Text =
MyexcelSheet.Range("S" & (i + 6)).Value
'下一步推进重点
ActivePresentation.Slides(i).Shapes("PlanTable").Table.Cell(3, 6).Shape.TextFrame.TextRange.Text =
MyexcelSheet.Range("T" & (i + 6)).Value
'存在的问题与困难
ActivePresentation.Slides(i).Shapes("PlanTable").Table.Cell(3, 7).Shape.TextFrame.TextRange.Text =
MyexcelSheet.Range("U" & (i + 6)).Value
'投资安排情况
ActivePresentation.Slides(i).Shapes("MoneyTable").Table.Cell(3, 1).Shape.TextFrame.TextRange.Text =
MyexcelSheet.Range("Y" & (i + 6)).Value
ActivePresentation.Slides(i).Shapes("MoneyTable").Table.Cell(3, 2).Shape.TextFrame.TextRange.Text =
MyexcelSheet.Range("Z" & (i + 6)).Value
ActivePresentation.Slides(i).Shapes("MoneyTable").Table.Cell(3, 3).Shape.TextFrame.TextRange.Text =
MyexcelSheet.Range("AA" & (i + 6)).Value
ActivePresentation.Slides(i).Shapes("MoneyTable").Table.Cell(3, 4).Shape.TextFrame.TextRange.Text =
MyexcelSheet.Range("AB" & (i + 6)).Value
'2017年目标
ActivePresentation.Slides(i).Shapes("Goal2017TextBox").TextFrame.TextRange.Text = "2017 年计划进度目标:"
& MyexcelSheet.Range("M" & (i + 6)).Value
ActivePresentation.Slides(i).Copy
ActivePresentation.Slides.Paste
Next

最后关闭表格链接,清除数据:
MyexcelBook.Close
Set MyexcelApp = Nothing
Set MyexcelBook = Nothing
Set MyexcelSheet = Nothing

放映并执行代码,完成!(ps,我把代码放到一个button的点击事件中了)

qq%e6%88%aa%e5%9b%be20160919113711

剩下的工作就是排版和更新图片了。虽然仍有很多工作量,但是已经大大减少了,不是么。