vba把EXCEL的表格分类放到PPT里，有新建有改建，需要点基础。做了注释。
本帖最后由 etkane 于 2024-10-15 10:22 编辑10/15 突然出现个莫名其妙的问题。
新建页面的时候，超过25页会卡一下，但是循环会继续，导致PPT新建页数与EXCEL表行不一致。
改用DO WHILE 判断，避免这种莫名其妙问题（不知道是不是个例，之前正常，前几天开始不正常）
9/25有个变量写错了，sd写成SH了。
说明：
1、为什么要用VBA？单位电脑不让用别的。。
2、怎么操作？ office 全家桶，开发工具。
3、很多我自己可能就用一次，没有写那些功能选择啥的，比如这个，里面用了goto跳转，按需跳转，按需删除均可。
4、版主友善提醒我要放到代码里，我偷懒了，版主帮我放了，这次我写了下注释。
5、这次代码是在PowerPoint里运行。
6、表格和PPT都打开，自动读取当前表格和PPT。
7、PPT VBA 里，可能需要在编辑器引用excel的com接口，具体为PPT VBA 编辑器 内的 菜单栏选择： 工具👉引用👉选Microsoft EXCEL 。。。。（后面不同版本不同了）
8、这个写了两遍，第一遍没保存。。
9、我觉得挺好用的：）特别对于汇报多的。
版主挺友善：）
Sub 提取EXCEL到PPT表格()
'调用EXCEL（打开的）
Dim xlapp As Object
Set xlapp = GetObject(, "excel.application")
Dim sh As Worksheet
Set sh = xlapp.Application.ActiveSheet
Dim pgc As Integer
pgs = 6 'excel rows start
pgc = sh.UsedRange.Rows.Count 'excel rows end
Debug.Print (pgc)
'定义PP,
Dim pr As Presentation
Set pr = ActivePresentation
Dim sd1 As Slide
Set sd1 = pr.Slides(1)
'删除原来的部分内容，按需删除本段
On Error Resume Next
For i = 2 To pr.Slides.Count
pr.Slides(i).Shapes("原始信息").Delete
pr.Slides(i).Shapes("b1").Delete
pr.Slides(i).Shapes("b2").Delete
pr.Slides(i).Shapes("b3").Delete
pr.Slides(i).Shapes("面积显示").Delete
Next i
'GoTo tiao '按需，跳功能，没做弹出选择。
'删除所有页，重新按需建表，按需删除
Debug.Print pr.Slides.Count
For i = 2 To pr.Slides.Count
pr.Slides(2).Delete
Next i
'新建对应表格的页数，复制第一页
pr.Slides(1).Copy
i = pgs
Do While pr.Slides.Count <= pgc - pgs + 1
'Debug.Print i, pgs, pgc
pr.Slides.Paste
i = i + 1
Loop
Debug.Print "新建对应表格的页数，复制第一页完成"
'tiao:
GoTo xinjian
Debug.Print "增加新的信息到每一页（从第一页复制）"
'增加新的信息到每一页（从第一页复制）
ActiveWindow.Selection.Unselect
ActivePresentation.Slides(1).Select
For i = 2 To sd1.Shapes.Count
ActivePresentation.Slides(i).Shapes(i).Select (msoFalse)
Next i
ActiveWindow.Selection.Copy
Debug.Print "将表格复制到每一页"
'将表格复制到每一页
'On Error Resume Next
For i = 2 To pr.Slides.Count
pr.Slides(i).Shapes.Paste
Next i
xinjian:
'读取并填充PPT内表格
Debug.Print "读取并填充PPT内表格"
For i = pgs To pgc
'Debug.Print i, sh.Range(sh.Cells(i, 2), sh.Cells(i, 2)).Text
pr.Slides(i - 4).Shapes("标题 1").TextFrame.TextRange.Text = sh.Range(sh.Cells(i, 3), sh.Cells(i, 3)).Text & "_" & sh.Range(sh.Cells(i, 15), sh.Cells(i, 15)).Text & "_" & sh.Range(sh.Cells(i, 17), sh.Cells(i, 17)).Text
For n = 2 To 24
If n < 13 Then
k = 1
pr.Slides(i - 4).Shapes("b1").Table.Cell(3, n - k).Shape.TextFrame.TextRange.Text = sh.Range(sh.Cells(i, n), sh.Cells(i, n)).Text
ElseIf n < 22 Then
k = 12
pr.Slides(i - 4).Shapes("b2").Table.Cell(3, n - k).Shape.TextFrame.TextRange.Text = sh.Range(sh.Cells(i, n), sh.Cells(i, n)).Text
ElseIf n < 24 Then
k = 22
pr.Slides(i - 4).Shapes("b3").Table.Cell(3, n - k).Shape.TextFrame.TextRange.Text = sh.Range(sh.Cells(i, n), sh.Cells(i, n)).Text
End If
Next n
'pr.Slides(i).Select
Debug.Print "当前行", i
Next i
End Sub
优秀，参考一下 用vba的都是上班不摸鱼的 学习学习，看能不能用上 这是市场部用的嘛:lol
优秀，参考一下 用VBA的都是牛人，我单位也不让用别的 可以，这个可以研究 dazuyishi1314 发表于 2024-9-24 01:06
这是市场部用的嘛
不是，搞基建的。 不太会用，运行了一下没报错，但是并没有实现自动复制表格到ppt的效果{:1_909:}
页:
[1]
2