PPT2016内嵌Excel的动态图表

背景

在excel中可以通过窗体或ActiveX控件达到动态控制图表显示的目的，但当Excel图表作为对象内嵌到PPT后，在PPT播放模式下，所有在Excel对象中的控件都是不可选的，只能在PPT的编辑模式下双击对象后在Application.Excel中进行控制。那么怎样才能在PPT播放模式下可以控制插入的Excel图表动态显示？一个方法是借助PPT中的VBA编程，用PPT中的ActiveX控件(注意在PPT中没有窗体工具中的控件)控制内嵌的Excel对象中的相关单元格区域，达到动态控制。

先在Excel中生成动态图表，方法参照这篇博客Excel2016制作动态图表,这里利用之前生成的动态图表嵌入到PPT中，用VBA编程调用excel中的数据，在PPT播放时展示动态图表，效果图：

---

1、在PPT中插入excel对象

点击插入–>对象–>选择由文件创建–>点击浏览，将之前做好的excel表格导入

导入之后，可以适当调整表格的位置

2、在PPT中插入组合框

开发工具 –>选择“组合框”

（若菜单没有“开发工具”选项，从文件—>选项—>自定义功能区，在右侧主选项卡区域下，勾选开发工具选项）

3、编写程序

　插入“组合框”控件后，按Alt+F11就可以在VBE中看到工程中显示出了一个Slide对象(只有加入了ActiveX控件后才能在工程资源管理器中出现Slide对象)，如下图：

• 在右侧代码区输入以下代码：

1、下面这段代码所做的事情，就是在每次 PPT 放映、下拉框被选择的时候，就去打开那个嵌入在 PPT 里的 Excel 文件，读取其中 sheet1工作表的 K2：K6范围，把这些选择项赋给下拉框。
注意需要结合自己的excel表修改上面粗体部分才行，第一个【sheet1】表示表格的第几个工作表，新建一个excel表时默认为sheet1，第二个【K2：K6】，这里放的是下拉框里的内容。这里需要将之前生成的excel表中 K2：K6区域的“1月，2月，3月，4月，5月”改为“1，2，3，4，5，”否则后面数据调用显示不正确。第三个修改【 Sh.Range(“C9”) = ComboBox1.Value】，本文的excel表C9单元格，放置的是引用数据，根据自己的设置修改此处。

代码段1

Option Explicit'声明公共变量Dim Wb As Object, Sh As Object, SouceRng As Object, TarCell As Object, ListRng As Object'当控件获得焦点时运行Private Sub ComboBox1_GotFocus()    Dim i As Integer    '设置Wb为内嵌的Excel工作薄，Sh为指定工作表，SouceRng和TarCell为指定单元格区域    Set Wb = Me.Shapes(1).OLEFormat.Object 'Me表示正在播放的Slide    Set Sh = Wb.worksheets("Sheet1")    Set ListRng = Sh.Range("K2：K6")    If ComboBox1.ListCount = 0 Then       With ComboBox1           For i = 1 To ListRng.Count               .AddItem ListRng.Cells(i)           Next i           End With           ComboBox1.ListRows = ListRng.Count     End If     ComboBox1.ListIndex = 0     Sh.Range("C9") = ComboBox1.ValueEnd Sub

2、当用户下拉选择时，组合框的 change 事件就会被触发，执行这段代码，将下拉框的选择结果填写到嵌入的 Excel 文件的 dashboard 工作表的 A1 单元格，驱动模型动态切换图表。

代码段2

'当控件值改变时运行对内嵌工作薄单元格的改变Private Sub ComboBox1_Change()    '改变内嵌工作薄中相应单元格的值     Set Wb = Me.Shapes(1).OLEFormat.Object     Set Sh = Wb.worksheets("Sheet1")     Sh.Range("C9") = ComboBox1.ValueEnd Sub

3、如果 PPT 翻页或者退出放映了，就关闭那个嵌入的 Excel 文件。

代码段3

'当控件失去焦点时运行释放对象变量Private Sub ComboBox1_LostFocus()    Set ListRng = Nothing    Set Sh = Nothing    Set Wb = NothingEnd Sub

文档下载

资源下载