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

• 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 If
End 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 = Nothing
End 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 = Nothing
End 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 With
End 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.Clear
End Sub
Private 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.Clear
End 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)

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

技术交流，软件开发，欢迎微信沟通：