vba把EXCEL的表格分类放到PPT里，有新建有改建，需要点基础。做了注释。

etkane

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、我觉得挺好用的：）特别对于汇报多的。
版主挺友善：）

[Asm] 纯文本查看 复制代码

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

abcdef1305

优秀，参考一下

理想的海洋

用vba的都是上班不摸鱼的

xxnn520

学习学习，看能不能用上

dazuyishi1314

这是市场部用的嘛

zk1126853389

优秀，参考一下

Don4R

用VBA的都是牛人，我单位也不让用别的

lipingtao

可以，这个可以研究

etkane

dazuyishi1314 发表于 2024-9-24 01:06
这是市场部用的嘛

不是，搞基建的。

wangkai213

不太会用，运行了一下没报错，但是并没有实现自动复制表格到ppt的效果