如何利用VBA自动生成PPT报告

本文是继python（多级表头）之后的另一个项目，主要是利用VBA实现自动更新PPT模板的功能。主要是常规的PPT太多了， 不想把时间浪费在Ctrl+C 和Ctrl+V 之间，唯有想想自动化的可行性了；
一开始时候是希望用Python（pptx）来写的，但感觉这个包兼容性不够好，生成的图表不能和现有的图型一致，并且该数据模板的制作时间也很长，所以还是用回微软他家的程序好了。（实验证明，①编程都是有其共同性的，看懂python，VBA也能大概看懂的；②工具不分等级高低，合适就行。）

首先，要感谢下周婷同学和网上的大神们，由于他们无私贡献出代码，我才能依葫芦画瓢（zhaochao）写出代码。。

先上代码，再一行行解释代码的作用。由于本人也是初学VBA，代码比较简陋，请大神们指导一下。谢谢。

PS：数据处理问题，我都放在excel处理了，所以这个VBA就是搬运数据的功能。。。

Sub 第一页()
    Dim pp As PowerPoint.Application   
    Dim pReport As PowerPoint.Presentation
    Dim pchtws1 As Worksheet
    Dim wb As Workbook
    Dim sh As Worksheet
    
    Application.ScreenUpdating = False
    
    
    '选定Excel页码
    Set wb = ThisWorkbook
    Set sh = Sheets("P1") 'sh选定P1页
    

    '启动PPT的功能，选定已打开的PPT模板。
    Set pp = CreateObject("powerpoint.application")
    Set pReport = pp.ActivePresentation
    
    '选定图表7的数据范围。
    Set pchtws1 = pReport.Slides(1).Shapes("图表 7").Chart.ChartData.Workbook.Worksheets(1)
    '通过excel表格，赋值给ppt对应的图表
    pchtws1.Range("A1:B4").Value = sh.Range("A1:B4").Value

     '同上，更新图表8的内容。
    Set pchtws1 = pReport.Slides(1).Shapes("图表 8").Chart.ChartData.Workbook.Worksheets(1) ''修改范围
    pchtws1.Range("D1:E4").Value = sh.Range("D1:E4").Value
    
    
    '更新表格1数据，由于无法直接修改PPT中Table的数据，那我只能把Excel的数据直接黏贴至PPT中。
    '这里面的PasteSpecial ppPasteDefault是默认采用Excel的格式，所以请先固定好Excel的格式。
    '这里的位置由于不是cm制，所以需要转换pt = cm * 72 / 2.54
    sh.Range("A1:B4").Select
    
    Selection.Copy
    
    pReport.Slides(1).Shapes(1).Select
    pReport.Slides(1).Shapes.PasteSpecial ppPasteDefault
    
     Dim h, w, l, t
     
     'cm制
     
     h = 3
     w = 13
     l = 3.1
     t = 12.34
     
     '我每页PPT的表格位置都不同，所以不适用，只适用于固定位置模板，先保留吧。
'    h = sh.Range("G1").Value
'    w = sh.Range("G2").Value
'    l = sh.Range("G3").Value
'    t = sh.Range("G4").Value

    With pp.ActiveWindow.Selection.ShapeRange
    
    'pt制，换算单位：pt = cm * 72 / 2.54
    
        .Height = h * 72 / 2.54
        .Width = w * 72 / 2.54
        .Left = l * 72 / 2.54
        .Top = t * 72 / 2.54
    End With
   
    
    '更新表格2数据
    
    
    sh.Range("D1:E4").Select
    
    Selection.Copy
    
    pReport.Slides(1).Shapes(1).Select
    pReport.Slides(1).Shapes.PasteSpecial ppPasteDefault
    
     
     'cm制
     
     'h = 0.03
     'w = 0.03
     l = 21.59
     t = 12.34
     
'    h = sh.Range("G1").Value
'    w = sh.Range("G2").Value
'    l = sh.Range("G3").Value
'    t = sh.Range("G4").Value

    With pp.ActiveWindow.Selection.ShapeRange
    
    'pt制，换算单位：pt = cm * 72 / 2.54
    
        '.Height = h * 72 / 2.54
        '.Width = w * 72 / 2.54
        .Left = l * 72 / 2.54
        .Top = t * 72 / 2.54
    End With
   
    Application.ScreenUpdating = True
    
    '由于PPT可能出现重名的情况，所以默认不提醒，直接覆盖掉原有PPT。
    Application.DisplayAlerts = False
    
    pReport.SaveAs ThisWorkbook.Path & "\" & Format(Now, "yyyy-MM-dd") & " " & "模板更新" & ".pptx"
    
    Application.DisplayAlerts = True
    
End Sub

参考资料：

http://www.exceloffice.net/archives/2091
（介绍了ppt的Application、Presentation、Worksheet等层级的关系。）
http://www.exceloffice.net/archives/1275
（介绍如何修改ppt对象的格式）
https://blog.csdn.net/olivesun88/article/details/50980698
（介绍如何把数据copy到PPT中）
https://blog.csdn.net/smking/article/details/4975324
（介绍VBA操作PPT）
http://club.excelhome.net/thread-1484716-1-1.html
（我之前在ExcelHome提问的全过程，也就是我自己的解决问题的过程。。）

参考资料太多了，就不全写了，感谢无私奉献的互联网er。

附件贴不上CSDN，请移步去ExcelHome看附件。