​​​本文于2023年5月1日首发于本人同名公众号：Excel活学活用，更多文章敬请关注！

☆本期内容概要☆

本期内容信息量相当的大，内容涉及很多方面，请耐心阅读，肯定不会让你失望的！建议收藏！

Excel中记账凭证的打印，几种思路Excel表记账的缺点最新的打印方法：勾选凭证列表，点打印即可Excel连接外部数据库（Excel文件）的方法SQL语句查询Excel文件数据循环打印的设计思路

我们前面分享过好几期“财务记账模板”相关内容，通过这么一个实例，向大家介绍Excel公式函数、VBA在财务管理中的运用，感兴趣的小伙伴可以翻翻前面的文章，这里我就不贴链接了。

今天我们要分享的主题是“凭证打印”，相信很多采用Excel来记账的财务小伙伴们肯定有这个困扰，凭证录进去了，怎么才能方便地把它打印出来呢？这个问题，我也是一路踩坑过来的：

刚开始是采用套打方式，正好我还发过一篇文章，大家可以看看：Excel财务综合应用之一：小型账务系统（ 第五部分 凭证打印）

后来觉得套打很麻烦，改为直接用空白的纸打印了，把凭证格式设计好即可。

上面两种方式都是手工操作，筛选一张打印一张，如果一号凭证分录超过6条，那么再切换到“凭证打印2”接着打印。如果凭证量较少，尚可应付，如果凭证量多就很累了。

于是，就开动脑筋，想想能不能我点一下按钮，它就自动打印我需要的凭证？就像各种商业财务软件一样？经过一番努力，还真搞出来一个可以自动打印的凭证模板，它是一个单独的文件，与我们的“Excel财务记账模板”（实际使用的名称是：XXX公司_20XX年序时账，并且文件名称中一定要包含“序时账”，以供打印模板更新链接之用）放在同一个目录下，感觉还是比较爽的：

上面这版打印模板通过power query查询数据，实现打印功能，同时也包含了不少VBA代码，但这不是今天的重点，我们不展开。

随着工作量的增加，这种Excel记账模板的局限性就越发明显：

1、表格有时候非常慢，主要是公式、条件格式太多；

2、数据安全性极低，表现在两个方面，一是Excel文件有时候会莫名其妙地打不开了，你就哭吧，二是在操作的时候，非常容易误操作把一些数据给改了、删了，造成极大的麻烦。

于是我就下定决心，一定要搞一个“像样”的“财务管理系统”，以Excel为操作端，Access为数据存储端，以提高数据的安全性，操作的便利性。

经过大概3个多月的努力（平均到每天至少2-3个小时），终于开发完成，完全实现了一个小型财务软件所能有的功能。现在用起来不是一般的爽！有机会给大家介绍一下，现在分享的内容也有不少是来自这个“财务管理系统”。怎么看起来像打广告的？您先别急，就说到今天的重点了。

废话不多说了，我们试着打印一张凭证，把它打印到pdf文件中：

上面这个凭证打印的功能，就是移植自我的“财务管理系统”，当然经过了不少修改。我们下面介绍一下实现的思路：

1、我们在“明细账”表中增加一个命令按钮CmdVoucherPrint，把其Caption改为“凭证打印”。修改、增加了几个字段（减少修改代码的工作量）

2、增加一个用户窗体Usf_VoucherList，我是通过复制来的：

其中有很多其他按钮，在打印的时候是不显示的，我也没有把它删掉，代码也保留着，说不定后面还会用到，就这么着吧。

增加一张工作表vPrint，用于打印凭证内容，也是复制来的：

3、我们点击明细账中的“凭证按钮，启动Usf_VoucherList。

4、Usf_VoucherList启动时，读取明细账凭证数据到数组，我们这里采用的是SQL查询方式。

5、在这之前，我们需要定义几个自定义函数，不定义也行，直接在各个过程里写代码。但是，这几段代码可能会在很多地方用到，所以先定义一下：

'自定义函数，取得【文件扩展名】Function GetExtn(iName)    '获取文件后缀名    GetExtn = Right(iName, Len(iName) - InStrRev(iName, ".") + 1)End Function

代码解析：利用InStrRev函数，定位最右边一个“.”的位置，再结合Len、Right函数取得文件扩展名

'自定义函数，取得【数据库连接字符串】Function GetStrCnn(ByVal DbFile As String, Optional ByVal Psw As String = "")    Dim sType$    sType = GetExtn(DbFile)    If InStr(sType, "accdb") Then        GetStrCnn = "Provider=Microsoft.ACE.OLEDB.12.0;Jet OLEDB:Database Password=" & Psw & ";Data Source=" & DbFile    ElseIf InStr(sType, "xl") Then        GetStrCnn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & DbFile    End IfEnd Function

代码解析：根据不同的文件类型，确定不同的连接字符串，我们这里主要是连接Excel文件。对于连接access数据库的情况下，如果有密码的，我们还要把密码赋值给psw。

'自定义函数，取得【数据库查询结果的记录数据】Function GetData(DataFile, sql)    On Error Resume Next    Dim cnn As Object                            '数据库连接    Dim rs As Object                             '记录集对象    Dim StrCnn As String                         '连接语句    Dim aData()    Set cnn = CreateObject("ADODB.Connection")    Set rs = CreateObject("ADODB.Recordset")    On Error Resume Next    StrCnn = GetStrCnn(DataFile)                  '取得连接字符串    cnn.Open StrCnn                              '打开数据库链接    Set rs = cnn.Execute(sql)                    '执行查询，并将结果输出到记录集对象    GetData = rs.getrows                         '将记录输出到数组    rs.Close    cnn.Close    Set cnn = Nothing    Set rs = NothingEnd Function

代码解析：根据数据库文件，SQL语句，查询数据，将结果存到数组里，详见代码注释。

'自定义函数，取得【数据库查询结果的表头字段】Function GetFields(DataFile, sql)    Dim cnn As Object                            '数据库连接    Dim rs As Object                             '记录集对象    Dim StrCnn As String                         '连接语句    Dim aData()    Dim FieldsNum As Integer    Set cnn = CreateObject("ADODB.Connection")    Set rs = CreateObject("ADODB.Recordset")    StrCnn = GetStrCnn(DataFile)             '取得连接字符串    cnn.Open StrCnn                              '打开数据库链接    Set rs = cnn.Execute(sql)                    '执行查询，并将结果输出到记录集对象    FieldsNum = rs.Fields.Count              '字段数量    ReDim aData(FieldsNum - 1)    For i = 0 To FieldsNum - 1               '循环，把字段存入数组        aData(i) = rs.Fields(i).Name    Next    GetFields = aData    rs.Close    cnn.Close    Set rs = Nothing    Set cnn = NothingEnd Function

代码解析：根据数据库文件，SQL语句，查询数据，将表头字段存到数组里，详见代码注释。

'自定义函数，【数字转大写人民币】Function N2RMB(m)    Y = Int(Round(100 * Abs(m)) / 100)    j = Round(100 * Abs(m) + 0.00001) - Y * 100    f = (j / 10 - Int(j / 10)) * 10    a = IIf(Y < 1, "", Application.Text(Y, "[DBNum2]") & "元")    b = IIf(j > 9.5, Application.Text(Int(j / 10), "[DBNum2]") & "角", IIf(Y < 1, "", IIf(f > 1, "零", "")))    c = IIf(f < 1, "整", Application.Text(Round(f, 0), "[DBNum2]") & "分")    N2RMB = IIf(Abs(m) < 0.005, "", IIf(m < 0, "负" & a & b & c, a & b & c))End Function

代码解析：这个函数是网上抄来的，利用Text(nummber,"[DBNum2]")把数字转成中文大写。

Function ColorByName(colorName As String) As Long'这个函数是根据颜色名称来取得颜色值代码较多，前面也分享过这里就不贴了。有兴趣的同学可以点下面链接查看。也可以不用这个函数，直接给出代码值。

更新：Excel VBA 自定义函数/根据颜色名称中英文取得颜色值/

Excel VBA 自定义函数/取得颜色值/GetColor/ChatGPT来帮忙

6、窗体启动后，我们看到：

几个按钮的功能我在图里标示，这里我们分析一下代码：

（1）全选

Private Sub CmdSelectAll_Click()    With Me.LvVoucherList        If Me.CmdSelectAll.Caption = "全选" Then            For i = 1 To .ListItems.Count                .ListItems(i).Checked = True            Next            Me.CmdSelectAll.Caption = "全消"            Me.CmdSelectAll.BackColor = RGB(176, 224, 230)        Else             For i = 1 To .ListItems.Count                .ListItems(i).Checked = False            Next            Me.CmdSelectAll.Caption = "全选"            Me.CmdSelectAll.BackColor = RGB(143, 188, 143)        End If    End WithEnd Sub

点击一次，在“全选”，“全消”之间切换，同时改变控件的名称与颜色

（2）月份右边向上、向下箭头，用来切换月份：

Private Sub CmdUp_Click()    With Me.CmbMonth        For i = 0 To .ListCount - 1            If .Text = .List(i) Then                j = i                Exit For            End If        Next        If j = 0 Then            .Text = .List(.ListCount - 1)        Else            .Text = .List(j - 1)        End If    End With    Me.CmdSelectAll.Caption = "全选"    Me.CmdSelectAll.BackColor = RGB(143, 188, 143)    Me.LvDetail.ListItems.ClearEnd SubPrivate Sub CmdDown_Click()    With Me.CmbMonth        For i = .ListCount - 1 To 0 Step -1            If .Text = .List(i) Then                j = i                Exit For            End If        Next        If j = .ListCount - 1 Then            .Text = .List(0)        Else            .Text = .List(j + 1)        End If    End With    Me.CmdSelectAll.Caption = "全选"    Me.CmdSelectAll.BackColor = RGB(143, 188, 143)    Me.LvDetail.ListItems.ClearEnd Sub

代码解析：点击一次，me.cmbmonth的listindex增减1，遇到list开头再向上，则返回结尾，遇到结尾再向下则回到开头。原来是简单地在“20XX01~20XX12”之间循环，但是遇到某些月份没有数据就不好办了，要么报错，如果用On Error Resume Next则显示空白的列表，不爽。

（3）窗体启动代码：Private Sub UserForm_Activate()，代码较长，我贴到第二条文章，下面的解释是AI贡献的，我也懒得去写了，将就着看吧：

1. 声明变量：声明一个对象变量DicMonth，一个ListItem变量LvItem，一个字符串数组sData，以及其他一些变量。

2. 设置用户表单的一些属性：设置CmdUp、CmdDown按钮的高度、顶部和左边位置，设置用户表单的标题、背景颜色等。

3. 创建一个字典对象DicMonth。

4. 设置一些控件的属性：设置LbTitle、CmdSelectAll、CmdPrint等控件的属性。

5. 定义SQL查询语句：定义三个SQL查询语句，用于从明细账表中获取数据。

6. 获取数据：使用GetData函数从工作簿中获取数据，并将结果存储在aData变量中。

7. 获取字段名：使用GetFields函数从工作簿中获取字段名，并将结果存储在sTbtitle变量中。

8. 设置ListView控件的列头：根据字段名设置LvVoucherList和LvDetail控件的列头。

9. 设置ListView控件的属性：设置LvDetail和LvVoucherList控件的显示外观、表格线、排序、复选框等属性。

10. 遍历数据：遍历aData中的数据，将月份信息添加到字典对象DicMonth中。

11. 设置ComboBox控件的属性：将字典对象DicMonth的键值作为CmbMonth控件的列表项，并设置控件的样式和默认选中项。

12. 清空ListView控件的列表项：清空LvVoucherList控件的列表项。

13. 添加列表项：根据选中的月份，将符合条件的数据添加到LvVoucherList控件的列表项中。

14. 获取明细账表的字段名：使用GetFields函数从工作簿中获取明细账表的字段名，并将结果存储在tbTitle变量中。

15. 设置ListView控件的列头：根据明细账表的字段名设置LvDetail控件的列头。

总结：这段代码主要是在激活用户表单时，对表单中的一些控件进行设置，包括按钮的位置、大小，表单的标题、背景颜色等。同时，从工作簿中获取数据，并将数据添加到ListView控件中，以便用户查看和操作。通过设置ComboBox控件，可以让用户选择不同的月份，从而显示对应月份的数据。整个过程涉及到了一些Excel VBA编程的基本操作，如声明变量、定义SQL查询语句、获取数据、设置控件属性等。

（4）打印：Private Sub CmdPrint_Click()，代码较长，我也把它贴到第二条文章，下面的解释也是AI贡献的，基本能说明问题：

1. 定义所需的变量，如日期、凭证号、数组等。

2. 检查是否已选择打印机，如果没有，则退出子程序。

3. 关闭屏幕更新和警报，以提高性能。

4. 激活名为"vPrint"的工作表，并使其可见。

5. 获取用户选择的月份和已勾选的凭证号。

6. 如果没有勾选任何凭证，弹出提示框并退出子程序。

7. 根据勾选的凭证号，从名为"明细账"的工作表中获取相关数据。

8. 获取数据表的字段名，并确定各字段在数组中的位置。

9. 根据凭证号对数据进行分组，并计算每组的行数。

10. 遍历每个凭证，将其数据填充到"vPrint"工作表中。

11. 设置单元格格式，如数字格式、合计大写金额等。

12. 打印工作表，并在打印完成后等待1秒。

13. 计算总页数，并在打印完所有凭证后弹出提示框。

14. 卸载当前窗体，并激活名为"明细账"的工作表。

整个过程中，代码会不断读取和操作Excel工作表中的数据，以实现凭证的打印功能。

我补充解释一下实现凭证打印的关键点：

1、获取需要打印的凭证的凭证号，存到数组arrNumber里，也就是我们窗体中列表勾选的记录。

2、根据月份、arrNumber，从明细账中查询数据，存到arrSelected

sql = " select * from  [明细账$] where 月份='" & iMonth & "' and 凭证号 in (" & numberStr & ")"arrSelected = GetData(myDataFile, sql)

这里的numberStr来自前面的数组arrNumber

 numberStr = Join(arrNumber, "','") numberStr = "'" & numberStr & "'"

这里值得注意的是，numberStr作为SQL语句的条件，要注意类型的匹配。如果是整数数值，那么直接numberStr = Join(arrNumber, ",")就好，如果是文本，那要加上单引号，如上面两行所示。

3、重设arrNumber，取得每个凭证的分录数：

 sql = "select 凭证号,count(凭证号) as 分录数 from (" & sql & ") group by 凭证号" arrNumber = GetData(myDataFile, sql)

这里的SQL从面前的SQL中再次查询“凭证号”、“分录数”，再存到数组arrNumber中，这里也可以使用另一个数组，但定义的太多也容易乱。

4、循环arrNumber，根据凭证号从arrSelected中提取一个凭证号的记录，存到数组arrPrint中，然后再把arrPrint数据写入工作表vPrint

5、这里要处理凭证分录多于6条的情况，就是第3条的意义所在。

iPage = Application.WorksheetFunction.RoundUp(iRow / 6, 0)

循环1 to ipage ，每6条分录打印一次，凭证号相应设置成“记-001,2/2”格式：

 .Cells(5, 7) = arrPrint(0, PosNumber) & "," & i & "/" & iPage

6、这里的细节有很多，不再细说了，有机会再分别讲吧。感兴趣的可以仔细分析一下代码。

另外，由于明细账表头字段修改，“科目汇总”代码也做了修改。对于双击汇总科目展示明细记录的代码，修改了LvDetail的字段宽度，根据明细账单元格的宽度来确定（arrWidthDetail）：

 With Sheets("明细账")        For i = 1 To iCol            If Cells(1, i) <> "" Then                ReDim Preserve arrWidthDetail(i - 1)                arrWidthDetail(i - 1) = Cells(1, i).Width            End If        Next    End With

原来是这样的：

arrWidthDetail = Array(60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60)

由于明细账字段增加，它的元素个数都不够用了，报错。索性改了吧。

好，今天就分享到这，欢迎点赞、留言、分享，谢谢大家，我们下期再会。

☆猜你喜欢☆

Excel VBA 这样酷炫的日期控件，你不想要吗？

Excel 公式函数/数据透视表/固定资产折旧计提表！

Excel VBA 自定义函数/数组字段定位/数组字段排序

Excel 功能/公式函数/VBA/多种姿势处理重复值

Excel VBA 最简单的收发存登记系统

Excel 公式函数/查找函数之LOOKUP

Excel VBA 文件批量改名

Excel 公式函数/数据验证/动态下拉列表

Excel VBA 输入逐步提示/TextBox+ListBox

Excel 基础功能【数据验证】，你会怎么用？

​​​​本文于2023年5月1日首发于本人同名公众号：Excel活学活用，更多文章敬请关注！