实用VBA：13.Excel数据批量套模板输出pdf文件

最新推荐文章于 2025-03-13 09:29:46 发布

周公笃行

最新推荐文章于 2025-03-13 09:29:46 发布

阅读量2.7k

点赞数 25

分类专栏： VBA Excel 办公自动化文章标签： excel pdf

本文链接：https://blog.csdn.net/chinajavafan/article/details/135318527

版权

VBA 同时被 3 个专栏收录

22 篇文章

订阅专栏

办公自动化

15 篇文章

订阅专栏

Excel

13 篇文章

订阅专栏

1.需求场景

前面与大家分享了使用VBA批量将Excel数据套模板输出为单独文件的方法（见）和套模板时插入图片的方法（见实用VBA：10.用VBA向Excel文件中自动插入图片）。在此基础上，我们常常希望将套模板输出的文件保存为pdf文件，以免在后续工作流程中excel文件被误修改了内容或格式。

2.解决思路

可以继续沿着前面批量套模板输出的思路进行完善，在输出保存excel文件之前或者保存之后关闭文件之前，对套模板生成的excel表格文件进行一次另存操作，输出为pdf文件。vba中提供了另存为其他格式的方法，只需要构造一个自己的pdf输出的方法，设置好保存路径和pdf文件参数就可以了。将文件名作为该方法的输入参数。这个方法在excel文件插入图片的代码里进行补充完善。

'输出pdf的方法

Function OutputPdf(person As String)

    Dim fn As String

    '拼接文件存储路径，输出的pdf文件与导出的excel文件存储在相同目录下

    fn = ThisWorkbook.Path & "\人员信息表\" & person

    '输出pdf文件

    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _

                           filename:=fn, _

                           Quality:=xlQualityStandard, _

                           IncludeDocProperties:=True, _

                           IgnorePrintAreas:=False, _

                           OpenAfterPublish:=False

End Function

3.VBA实现

完整代码如下：

'定义工作簿变量

Dim wb As Workbook

'定义工作表变量

Dim ws, sh As Worksheet

'定义临时存储基本信息数据各字段的变量

Dim pName, pSex, pBirthday, pJob, pLocation, pSchool, pLevel, pUnit, pWorkYear, pPhone, pCareer, pAwards, myPath As String

'循环变量

Dim i As Integer

'定义图形对象变量

Dim sp As Shape



Public Sub 按模板输出工作表()

    '设置工作簿为当前工作簿

    Set wb = Workbooks(1)

    '设置基础数据表、填表模板到表变量

    Set ws = Worksheets("数据")

    Set sh = Worksheets("模板")

    '关闭屏幕刷新

    'Application.ScreenUpdating = False

    '逐行读取人员基本信息，每行信息(即每个人的信息)填入表格后另存为单独文件

    For i = 2 To 22

        '设置数据表为当前激活的表格

        ws.Activate

        '将当前行各列单元格信息存至临时变量

        pName = Cells(i, 1).value

        pSex = Cells(i, 2).value

        pBirthday = Cells(i, 3).value

        pJob = Cells(i, 4).value

        pLocation = Cells(i, 5).value

        pSchool = Cells(i, 6).value

        pLevel = Cells(i, 7).value

        pUnit = Cells(i, 8).value

        pWorkYear = Cells(i, 9).value

        pPhone = Cells(i, 10).value

        pCareer = Cells(i, 11).value

        pAwards = Cells(i, 12).value

        '设置模板表格为当前激活的工作表

        sh.Activate

        '将临时变量信息写入模板对应单元格

        Cells(2, 2).value = pName

        Cells(2, 4).value = pSex

        Cells(2, 6).value = pBirthday

        Cells(3, 2).value = pJob

        Cells(3, 4).value = pLocation

        Cells(4, 2).value = pLevel

        Cells(4, 4).value = pSchool

        Cells(5, 2).value = pWorkYear

        Cells(5, 4).value = pUnit

        Cells(5, 6).value = pPhone

        Cells(6, 2).value = pCareer

        Cells(7, 2).value = pAwards

        '删除旧图片

        For Each sp In ActiveSheet.Shapes

            sp.Select

            '如果图形类别为13则是图片，删除，否则不删除，以免合并单元格被误删除

            If sp.Type = 13 Then

                sp.Delete

            End If

        Next

        '以当前文件所在目录为根目录，拼接文件完整路径

        myPath = imgPath & "证件照\" & pName & ".JPG"

        '调用插入图片的自定义方法

        insertPicture filename:=myPath, picCell:=Cells(2, 7), picLoc:="照片"

        '填好表信息的模板工作表复制为新工作表

        sh.Copy

        '活动工作表名以人员姓名命名

        ActiveSheet.Name = pName

        '文件另存至当前文件夹“\人员信息表\”子目录下

        ActiveWorkbook.SaveAs filename:=ThisWorkbook.Path & "\人员信息表\" & i - 1 & ".人员信息表(" & pName & ").xlsx"

        

        '调用输出pdf文件的方法

        OutputPdf (pName)

        

        '关闭保存过的文件

        ActiveWorkbook.Close

    Next i

    '释放工作表和工作簿变量

    Set sh = Nothing

    Set ws = Nothing

    Set wb = Nothing

    '开启屏幕刷新

    'Application.ScreenUpdating = True

    '显示提示信息

    MsgBox "生成完毕,请到“人员信息表”目录下查看。"

End Sub



'自定义插入图片的方法

Sub insertPicture(ByRef filename As String, ByRef picCell As Range, ByRef picLoc As String)

    '判断指定路径下文件是否存在

    If Dir(filename) <> "" Then

        '插入图片

        ActiveSheet.Shapes.AddPicture(filename, msoFalse, msoTrue, picCell.Left, picCell.Top, -1, -1).Select

        '调整图片大小和位置

        With Selection.ShapeRange

            '锁定图片纵横比，避免变形

            .LockAspectRatio = msoTrue

            '上边缘比单元格上边缘多1个像素，避免遮盖边框线

            .Top = picCell.Top + 1

            '高度为单元格高度4倍减2像素，让出上下边缘线

            .Height = picCell.Height * 4 - 2

            '左边缘对齐位置

            .Left = picCell.Left + (picCell.Width - .Width) / 2

            '如果图片比例超宽，则宽度缩小到单元格宽,调整顶端对齐位置

            If .Width > picCell.Width Then

                '宽度调整为单元格宽减2像素

                .Width = picCell.Width - 2

                '左对齐到单元格左边缘加1像素

                .Left = picCell.Left + 1

                '上对齐向下调到居中位置

                .Top = picCell.Top + (picCell.Height * 4 - .Height) / 2

            End If

        End With

    Else

        Debug.Print pName & picLoc & "文件未找到。"

    End If

End Sub



'输出pdf的方法

Function OutputPdf(person As String)

    Dim fn As String

    '拼接文件存储路径，输出的pdf文件与导出的excel文件存储在相同目录下

    fn = ThisWorkbook.Path & "\人员信息表\" & person

    '输出pdf文件

    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _

                           filename:=fn, _

                           Quality:=xlQualityStandard, _

                           IncludeDocProperties:=True, _

                           IgnorePrintAreas:=False, _

                           OpenAfterPublish:=False

End Function