VBA如何自动更新PPT中的图表数据

hsl992

请教各位大神：

背景：我需要根据excel搭建好的计算模板，把里面的数据贴入到已有的PPT模板中（更新表格里面的数据）。但由于PPT页码太多了，所以想用VBA的方法，批量更新PPT中的图表信息。

附件是PPT和EXCEL的模板，我看了下别人的分享，我可以写成下面代码那样，把excel的值赋予给ppt中的图。但表格怎么弄呢？此外，选择窗格中，我是不是只能用chart("表格4")这样写法，有没有像序列号的写法？

大神能帮忙提供一个框架的代码吗？我模仿着来写。谢谢了。


    Set pchtws1 = pReport.Slides(n).Shapes("chart1").Chart.ChartData.Workbook.Worksheets(1) ''修改范围
    pchtws1.Range("B1:I1").Value = sh.Range("C7:J7").Value
    pchtws1.Range("A2:A14").Value = sh.Range("B8:B" & bb).Value
    pchtws1.Range("B2:I14").Value = sh.Range("C8:J" & bb).Value

例子.rar (53.38 KB, 下载次数: 151)

2019-6-22 12:45 上传

点击文件名下载附件

hsl992

顶一顶。有大神指点一下吗？

咸味

顶一下，看看有没有出大神出现！

hsl992

刚刚又尝试了一下，只实现了把图表里面的数据更新的功能。
PPT中的表格更新还是没能实现。查了资料，发现表格是Table，属于slides.shape的子集。但就是找不到对应的资料写这段码。。

求大神指导啊，我不是伸手拿资料的，真的查不到啊。。。5555

参考资料（点击进去）

1. Sub 测试()
   
2.     Dim pp As PowerPoint.Application
   
3.     Dim pReport As PowerPoint.Presentation
   
4.     Dim pchtws1 As Worksheet
   
5.     Dim pchtws2 As Worksheet
   
6.     Dim wb As Workbook
   
7.     Dim sh As Worksheet
   
8.    
   
9.     Application.ScreenUpdating = False
   
10.    
    
11.    
    
12.     '选定Excel页码
    
13.     Set wb = ThisWorkbook
    
14.     Set sh = Sheets("P1") 'sh选定P1页
    
15.    
    
16. 
    
17.     '打开演示文稿模板
    
18.     Set pp = CreateObject("powerpoint.application")
    
19.     Set pReport = pp.ActivePresentation
    
20.    
    
21.     '更新图表7数据
    
22.     Set pchtws1 = pReport.Slides(1).Shapes("图表 7").Chart.ChartData.Workbook.Worksheets(1) ''修改范围
    
23.     pchtws1.Range("A1:B4").Value = sh.Range("A1:B4").Value
    
24. 
    
25.      '更新图表8数据
    
26.     Set pchtws1 = pReport.Slides(1).Shapes("图表 8").Chart.ChartData.Workbook.Worksheets(1) ''修改范围
    
27.     pchtws1.Range("D1:E4").Value = sh.Range("D1:E4").Value
    
28.    
    
29.    
    
30.    
    
31.     Application.ScreenUpdating = True
    
32. End Sub
    
33. 
    

复制代码

hsl992

顶一顶。有大神在吗？

hsl992

顶顶更健康，求大神光临、

hsl992

刚刚模仿了别人写的内容，写了下面这段内容，并且也成功把excel的内容copy到了PPT上。

但问题是，我想把数据copy到已有的表格中，而不是新建一个表格。。。（如下图。）

难道我的Select有问题？


'更新表格2数据

    sh.Range("A1:B4").Copy
    pReport.Slides(1).Shapes("表格 1").Select
    pReport.Slides(1).Shapes.PasteSpecial DataType:=ppPasteDefault



--------------------------------------------------------------------------------------------------------------------------------------------------
此外，突然多了个问题。链接：https://zhidao.baidu.com/question/1366368314523863379.html

我怎么判断Shape是1，还是2，还是其他呢？从哪个位置可得出来呢？是从窗格的顺序看出来的吗？

hsl992

问了同事之后，才发现数据是不能在原有的Table上修改的，只能通过复制Excel，再黏贴（可以选择性黏贴，具体区别可以在录制宏下尝试，再回看代码区别。）

由于VBA是初学，所以很多地方写的很粗糙，请大神们点一点优化的地方。并且就一页PPT，代码写的那么长，如果能有折叠功能就好。（其实可以通过设置多个Sub 第一页，Sub 第二页这种分开，以后就好找点 。）

其中查到感觉比较有用的资料，有兴趣的同学可以查看：

http://club.excelhome.net/thread-1425161-1-1.html

http://www.exceloffice.net/archives/1275

https://blog.csdn.net/olivesun88/article/details/50980698

http://www.exceloffice.net/archives/2091

等等，其他太多了。

不多说，先上代码和压缩测试包：

例子.rar (65.25 KB, 下载次数: 588)

2019-6-23 09:19 上传

点击文件名下载附件

1. Sub 第一页()
   
2.     Dim pp As PowerPoint.Application
   
3.     Dim pReport As PowerPoint.Presentation
   
4.     Dim pchtws1 As Worksheet
   
5.     Dim pchtws2 As Worksheet
   
6.     Dim wb As Workbook
   
7.     Dim sh As Worksheet
   
8.    
   
9.     Application.ScreenUpdating = False
   
10.    
    
11.    
    
12.     '选定Excel页码
    
13.     Set wb = ThisWorkbook
    
14.     Set sh = Sheets("P1") 'sh选定P1页
    
15.    
    
16. 
    
17.     '打开演示文稿模板
    
18.     Set pp = CreateObject("powerpoint.application")
    
19.     Set pReport = pp.ActivePresentation
    
20.    
    
21.     '更新图表7数据
    
22.     Set pchtws1 = pReport.Slides(1).Shapes("图表 7").Chart.ChartData.Workbook.Worksheets(1) ''修改范围
    
23.     pchtws1.Range("A1:B4").Value = sh.Range("A1:B4").Value
    
24. 
    
25.      '更新图表8数据
    
26.     Set pchtws1 = pReport.Slides(1).Shapes("图表 8").Chart.ChartData.Workbook.Worksheets(1) ''修改范围
    
27.     pchtws1.Range("D1:E4").Value = sh.Range("D1:E4").Value
    
28.    
    
29.    
    
30.     '更新表格1数据
    
31.    
    
32.    
    
33.     sh.Range("A1:B4").Select
    
34.    
    
35.     Selection.Copy
    
36.    
    
37.     pReport.Slides(1).Shapes(1).Select
    
38.     pReport.Slides(1).Shapes.PasteSpecial ppPasteDefault
    
39.    
    
40.      Dim h, w, l, t
    
41.      
    
42.      'cm制
    
43.      
    
44.      h = 3
    
45.      w = 13
    
46.      l = 3.1
    
47.      t = 12.34
    
48.      
    
49. '    h = sh.Range("G1").Value
    
50. '    w = sh.Range("G2").Value
    
51. '    l = sh.Range("G3").Value
    
52. '    t = sh.Range("G4").Value
    
53. 
    
54.     With pp.ActiveWindow.Selection.ShapeRange
    
55.    
    
56.     'pt制，换算单位：pt = cm * 72 / 2.54
    
57.    
    
58.         .Height = h * 72 / 2.54
    
59.         .Width = w * 72 / 2.54
    
60.         .Left = l * 72 / 2.54
    
61.         .Top = t * 72 / 2.54
    
62.     End With
    
63.    
    
64.    
    
65.     '更新表格2数据
    
66.    
    
67.    
    
68.     sh.Range("D1:E4").Select
    
69.    
    
70.     Selection.Copy
    
71.    
    
72.     pReport.Slides(1).Shapes(1).Select
    
73.     pReport.Slides(1).Shapes.PasteSpecial ppPasteDefault
    
74.    
    
75.      
    
76.      'cm制
    
77.      
    
78.      'h = 0.03
    
79.      'w = 0.03
    
80.      l = 21.59
    
81.      t = 12.34
    
82.      
    
83. '    h = sh.Range("G1").Value
    
84. '    w = sh.Range("G2").Value
    
85. '    l = sh.Range("G3").Value
    
86. '    t = sh.Range("G4").Value
    
87. 
    
88.     With pp.ActiveWindow.Selection.ShapeRange
    
89.    
    
90.     'pt制，换算单位：pt = cm * 72 / 2.54
    
91.    
    
92.         '.Height = h * 72 / 2.54
    
93.         '.Width = w * 72 / 2.54
    
94.         .Left = l * 72 / 2.54
    
95.         .Top = t * 72 / 2.54
    
96.     End With
    
97.    
    
98.     Application.ScreenUpdating = True
    
99.    
    
100.    
     
101. End Sub
     

复制代码

璇玑美玉

刚好遇到这个问题，学习一下，谢谢楼主！

gemini8806

hsl992 发表于 2019-6-23 00:10
刚刚模仿了别人写的内容，写了下面这段内容，并且也成功把excel的内容copy到了PPT上。

但问题是，我想把 ...

楼主，ppt右边那部分有图表编号序列的部分怎么调出来的。。。。