办公自动化——秒速生成个人名牌

前阵子组织了晋升干部的培训，然后在准备培训物料的过程中，有个环节是针对每个人准备一个名牌，用于放在自己的培训时的位置前面。大概如下图所示：

名牌样例.jpeg

从培训的同事那边了解到，他们是在PPT的模板里逐个逐个去把参训人员的名字打上去的。我觉得如果人少还好，人多了那工作量就不小了，而且这种机械重复的活，当然应该是用编程自动化来实现啦！
话不多说，就上网去搜索了相关的代码，然后进行了修改调试，因为之前都是在Excel里使用VBA的，这次是在PPT里面用VBA，所以还是费了比较大的劲的。
首先我们需要做一个竖版的PPT页面，我这里将我们之前用的竖版PPT的参数放在这里供大家参考：

PPT设计版面.png

这里的背景大家可以根据自己单位的情况把logo放上去，我这里为了保护隐私就把自己所在公司的logo盖住了。
然后还需要准备一个Excel，然后直接将参与培训人员的名单放到Excel里，非常简单的样式，如图所示：

名单Excel样式.png

做完上述步骤就是见证奇迹的时刻了！

将下述VBA的代码复制进VBA的编辑器里：

Sub PPT批量生成名牌()

    Dim pptPre As Presentation
    Dim p As Long
    Dim n As Integer
    Dim appExcel As Object
    Dim myexcel As Object
    Dim mysheet As Object
    Dim rcount As Long
    
    Set pptPre = ActivePresentation
    Set appExcel = CreateObject("Excel.Application") '创建excel对象
    Set myexcel = appExcel.Workbooks.Open("\\Mac\Home\Desktop\工作\简书\名牌自动生成\名单.xlsx") '打开工作表
    Set mysheet = myexcel.sheets("Sheet1") '创建工作表对象
    rcount = mysheet.Cells(mysheet.Rows.Count, "A").End(3).Row '获取工作表最后一行行号
    
    For p = 2 To rcount '从第2行到最后一行
            n = n + 1
            
            ActivePresentation.Slides(1).Copy '复制第一张幻灯片
            ActivePresentation.Slides.Paste (ActivePresentation.Slides.Count + 1) '粘贴至最后一张之后
            
            'pptPre.Slides(ActivePresentation.Slides.Count).Shapes.AddPicture FileName:=myPath & _
            'mysheet.Cells(p, "A").Value & ".jpg", LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
            'Left:=20, Top:=20, Width:=40, Height:=60 '插入图片，设置坐标及长宽
            
            'For C = 2 To 4 '循环插入文本框
                With ActivePresentation.Slides(ActivePresentation.Slides.Count)
                    With .Shapes.AddTextbox(msoTextOrientationHorizontal, 70, 220, 400, 10) '文本框坐标及长宽
                         .TextFrame.TextRange.Font.Color.RGB = RGB(31, 85, 160) '字体颜色
                         .TextFrame.TextRange.Font.Size = 103 '字号
                         .TextFrame.TextRange.Font.Bold = msoTrue
                         .TextFrame.TextRange.Text = mysheet.Cells(p, 1).Value '文本内容
                         .IncrementRotation 180
                    End With
                End With
                With ActivePresentation.Slides(ActivePresentation.Slides.Count)
                    With .Shapes.AddTextbox(msoTextOrientationHorizontal, 130, 500, 400, 10) '文本框坐标及长宽
                         .TextFrame.TextRange.Font.Color.RGB = RGB(31, 85, 160) '字体颜色
                         .TextFrame.TextRange.Font.Size = 103 '字号
                         .TextFrame.TextRange.Font.Bold = msoTrue
                         .TextFrame.TextRange.Text = mysheet.Cells(p, 1).Value '文本内容
                    End With
                End With
    Next p
    
    myexcel.Close
    
    Set pptPre = Nothing
    Set appExcel = Nothing
    Set myexcel = Nothing
    Set mysheet = Nothing
End Sub

对于上述代码，每个人需要根据自己名单Excel所在的文件位置修改第13行代码。

然后准备就绪后，运行代码，就可以一瞬间完成所有Excel名单上人员的名牌生成，假如Excel上有100个人，那么就是一瞬间生成100个PPT名牌，如果是200人，那就是一瞬间200个！
效果如图：

最终效果图.png

一下子就完成了50个名牌的生成，然后打印出来再进行折叠装订，就可以形成文章最开始呈现的效果了。