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

快速浏览

往期合集：【2023年3月】【2023年4月】【2023年5月】【2023年6月】【2023年7月】

实用案例

|收费管理系统|中医诊所收费系统|

|日期控件|简单的收发存|

|电子发票管理助手|Excel表格拆分神器|

|Excel多种类型文件合并|电子发票登记系统（Access版）|

收费使用项目

|财务管理系统|

内容提要

• 根据序时账批量生成会计凭证抽查底稿
• SQL语句查询Excel表数据

大家好，我是冷水泡茶，前两天在论坛上看到一个求助贴：

他的明细表“序时账”是这样的，有几千条数据：

还有一张“会计凭证抽查”表，（已被我改为“凭证抽查（模板）”）：

他的需求是：从“序时账”中抽出“现金”科目借方金额排名前3的凭证，填到这张抽查表中，作为审计底稿。

有很多人给出了方法，有用数组、字典的，也有用SQL的，都能达到目的。我看这么多人都做了，也看了几个答案，也就没有掺和。那你不禁要问：你到底在说什么？

请先别急，前面是引子，下面是我今天的重点：

楼主开始只要做一个“现金”科目，后来又提了不少要求，包括改变科目等。我突然想起我们做过不少批量生成工作表、循环打印工作表等案例，像他这样做审计的话，是不是会有这种需求：把所有科目，或者说选择几个科目做成会计凭证抽查底稿呢？

我觉得这种需求应该是很多人都会有的，于是就着手做了起来，走不不少弯路，这里就不多说了，我们看结果：

基本思路

1、把所有科目列出来，供选择，由于科目较多，我们选择用ListBox。

2、设置查询条件：

（1）排序方式：前几名、随机；

（2）凭证数量：预置1~10，供选择，也可以手输；

（4）金额方向：借、贷，根据明细账中相应字段设置为“借方金额”、“贷方金额”。

3、可以直接打印，也可以生成表格。

4、设置一个窗体，把这些控件放上去。

程序代码

1、用户窗体UserForm1：

Dim arrData() Dim arrTem() Dim arrAccName() Private Sub CmbDirection_Change() accDirection = Me.CmbDirection.Text End Sub Private Sub CmbQuantity_Change() RdQuantity = Me.CmbQuantity End Sub Private Sub CmbSortType_Change() SortType = Me.CmbSortType End Sub Private Sub CmdCreateSheets_Click() '循环ListBox For i = 0 To Me.LstAccName.ListCount - 1 If Me.LstAccName.Selected(i) Then accName = Me.LstAccName.List(i) Call SelectData(accName) Call CopyWorksheet(accName) End If Next MsgBox "抽查表已生成！" Unload Me End Sub Private Sub CmdExit_Click() Unload Me End Sub Private Sub CmdPrint_Click() If Application.Dialogs(xlDialogPrinterSetup).Show = False Then Exit Sub End If '循环ListBox For i = 0 To Me.LstAccName.ListCount - 1 If Me.LstAccName.Selected(i) Then accName = Me.LstAccName.List(i) Call SelectData(accName) Call PrintSheet End If Next MsgBox "抽查表打印完成！" Unload Me End Sub Private Sub CmdSelectAll_Click() '选择 lstaccname 中的所有项目 If Me.CmdSelectAll.Caption = "全选" Then For i = 0 To LstAccName.ListCount - 1 LstAccName.Selected(i) = True Next Me.CmdSelectAll.Caption = "全消" Else For i = 0 To LstAccName.ListCount - 1 LstAccName.Selected(i) = False Next Me.CmdSelectAll.Caption = "全选" End If End Sub Private Sub UserForm_Initialize() Set cnn = CreateObject("Adodb.connection") Set rs = CreateObject("Adodb.Recordset") Set wb = ThisWorkbook Set ws = ThisWorkbook.Sheets("凭证抽查（模板）") Set rng = ws.Range("A1:L13") '排序类型：取前几大金额或者随机取几个 With Me.CmbSortType .Clear .AddItem "前几" .AddItem "随机" .Text = "前几" End With SortType = Me.CmbSortType '抽取凭证数量,预置1~10,可直接修改 For i = 1 To 10 Me.CmbQuantity.AddItem i Next Me.CmbQuantity = 5 RdQuantity = Me.CmbQuantity '金额方向，取标题字段中包含“借”、“贷”字符的字段。 Set ws = ThisWorkbook.Sheets("序时账") With Me.CmbDirection .Clear With ws For i = 1 To ws.UsedRange.Columns.Count If InStr(.Cells(1, i), "借") Or InStr(.Cells(1, i), "贷") Then Me.CmbDirection.AddItem .Cells(1, i) End If Next End With .Text = .List(0) accDirection = .Text End With '数据库连接相关，取得“科目名称”（一级科目），原始数据如果不是一级科目的要转换成一级科目。 DbFile = ThisWorkbook.FullName StrCnn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & DbFile cnn.Open StrCnn SQL = "select distinct left(科目代码,4) as 科目代码,科目名称 from (select * from [序时账$] where len(科目代码) >0 order by 科目代码)" Set rs = cnn.Execute(SQL) arrAccName = rs.getrows '科目名称装入ListBox For i = 0 To UBound(arrAccName, 2) Me.LstAccName.AddItem arrAccName(1, i) Next End Sub

‍代码解析：

（1）窗体初始化，设置几个控件的初始值，把会计科目装入ListBox。

（2）几个条件控件，当他们发生改变时，更新相应的变量值。

（3）全选按钮，点一下选择所有科目，再点一下取消选择。

（4）直接打印，循环ListBox，根据选择的科目，调用SelectData过程，PrintSheet过程。

（5）生成表格，循环ListBox，根据选择的科目，调用SelectData过程，CopyWorksheet过程。

2、myModule模块：

Public DbFile As String Public StrCnn As String Public cnn As Object Public rs As Object Public SQL As String Public AccCode As String, accName As String Public ws As Worksheet Public SortType As String Public RdQuantity As Integer Public accDirection As Variant Public wb As Workbook Public rng As Range Sub SelectData(accName As String) Dim arrData(), tbTitle() Dim arrTem(), arrSelected() Dim arr1() Dim iRow As Integer Dim iCol As Integer Dim DateAndNo As String Dim lastRow As Long Set ws = ThisWorkbook.Sheets("凭证抽查（模板）") If SortType = "前几" Then SQL = "select top " & RdQuantity & " *" _ & " from [序时账$] where 科目名称='" & accName _ & "' and len(凭证字号)>0 ORDER BY " & accDirection & " DESC" Set rs = cnn.Execute(SQL) arrTem = rs.getrows iRow = UBound(arrTem, 2) iCol = UBound(arrTem, 1) ReDim arr1(0 To iRow, 0 To iCol) For i = 0 To UBound(arrTem, 2) For j = 0 To UBound(arrTem, 1) arr1(i, j) = arrTem(j, i) Next Next For i = 0 To Application.WorksheetFunction.Min(RdQuantity - 1, UBound(arr1, 1)) DateAndNo = DateAndNo & arr1(i, 0) & arr1(i, 1) & "','" Next DateAndNo = "'" & Left(DateAndNo, Len(DateAndNo) - 2) SQL = "select a.日期,a.凭证字号,a.摘要,a.科目名称,a.二级科目,a.借方金额,a.贷方金额 from [序时账$] a where 日期 & 凭证字号 in (" & DateAndNo & ")" Else SQL = "select distinct 日期,凭证字号 from [序时账$] where 科目名称='" & accName _ & "' and len(" & accDirection & ")>0 " Set rs = cnn.Execute(SQL) arrTem = rs.getrows iRow = UBound(arrTem, 2) iCol = UBound(arrTem, 1) ReDim arr1(0 To iRow, 0 To iCol) For i = 0 To UBound(arrTem, 2) For j = 0 To UBound(arrTem, 1) arr1(i, j) = arrTem(j, i) Next Next For i = 1 To 5 arr1 = ShuffleArray(arr1) Next For i = 0 To Application.WorksheetFunction.Min(RdQuantity - 1, UBound(arr1, 1)) strDate = strDate & arr1(i, 0) & "#,#" strNo = strNo & arr1(i, 1) & "','" DateAndNo = DateAndNo & arr1(i, 0) & arr1(i, 1) & "','" Next strDate = "#" & Left(strDate, Len(strDate) - 2) strNo = "'" & Left(strNo, Len(strNo) - 2) DateAndNo = "'" & Left(DateAndNo, Len(DateAndNo) - 2) SQL = "select a.日期,a.凭证字号,a.摘要,a.科目名称,a.二级科目,a.借方金额,a.贷方金额 from [序时账$] a where 日期 & 凭证字号 in (" & DateAndNo & ")" End If Set rs = cnn.Execute(SQL) arrData = rs.getrows iRow = UBound(arrData, 2) iCol = UBound(arrData, 1) ReDim arr1(0 To iRow, 0 To iCol) For i = 0 To UBound(arrData, 2) For j = 0 To UBound(arrData, 1) arr1(i, j) = arrData(j, i) Next Next ws.Activate With ws .Range("C4") = accName lastRow = ws.UsedRange.Rows.Count If lastRow > 13 Then .Range("a11:L" & lastRow - 3).Delete Shift:=xlUp .Range("A10:G10").ClearContents .Range("F11:G11").ClearContents [a11].Resize(iRow).EntireRow.Insert End With With Range("A10").Resize(iRow 1, 12) .Columns(6).Resize(, 2).NumberFormatLocal = "_ * #,##0.00_ ;_ * -#,##0.00_ ;_ * ""-""??_ ;_ @_ " .Rows(1).Copy .Cells .Columns(1).Resize(, 7).Value = arr1 .Cells(iRow 2, 6).Resize(, 2) = "=sum(" & .Columns(6).Address(0, 0) & ")" For i = 1 To Row 1 If Cells(i, 5) = "0" Then Cells(i, 5) = "" End If Next End With DateAndNo = "" End Sub Sub CopyWorksheet(accName As String) Dim sourceWorksheet As Worksheet Dim targetWorksheet As Worksheet Dim wsName As String '设置源工作表 Set sourceWorksheet = ThisWorkbook.Worksheets("凭证抽查（模板）") '设置目标工作表的名称 wsName = "凭证抽查表（" & accName & "）" '检查是否存在同名的目标工作表，如果存在则删除 On Error Resume Next Set targetWorksheet = ThisWorkbook.Worksheets(wsName) On Error GoTo 0 If Not targetWorksheet Is Nothing Then Application.DisplayAlerts = False targetWorksheet.Delete Application.DisplayAlerts = True End If '复制源工作表到同一个工作簿 sourceWorksheet.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) '获取新复制的工作表的引用 Set targetWorksheet = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) '重命名新复制的工作表 targetWorksheet.Name = wsName End Sub Sub PrintSheet() ThisWorkbook.Sheets("凭证抽查（模板）").PrintOut Copies:=1 Application.Wait Now TimeSerial(0, 0, 0.5) End Sub

代码解析：

（1）定义一些公共变量。

（2）SelectData过程，根据用户窗体中的各个控件值，产生不同的SQL语句，从“序时账”表中查询数据，一个科目一个科目写入“凭证抽查（模板）”。

（3）Copyworksheet过程，当一个科目数据写入凭证抽查（模板）后，把它复制成以这个科目命名的工作表，接着继续下一个科目。

（4）PrintSheet过程，当一个科目数据写入凭证抽查（模板）后，把它打出来，接着继续下一个科目。

3、自定义函数ShuffleArray：

SFunction ShuffleArray(arr As Variant) As Variant Dim numRows As Long Dim randomArr() As Variant Dim shuffledArr() As Variant Dim i As Long, j As Long Dim tempRow As Long '获取数组的行数 numRows = UBound(arr, 1) - LBound(arr, 1) 1 '创建一个与原始数组相同维度的新数组 ReDim randomArr(1 To numRows, 1 To 2) ReDim shuffledArr(LBound(arr, 1) To UBound(arr, 1), _ LBound(arr, 2) To UBound(arr, 2)) '填充随机数列 For i = 1 To numRows randomArr(i, 1) = i LBound(arr, 1) - 1 ' 原始行号 randomArr(i, 2) = Rnd() ' 随机数 Next '按照随机数列的第二列排序 For i = 1 To numRows - 1 For j = i 1 To numRows If randomArr(i, 2) > randomArr(j, 2) Then '交换两行的数据 tempRow = randomArr(i, 1) randomArr(i, 1) = randomArr(j, 1) randomArr(j, 1) = tempRow '交换随机数 tempRow = randomArr(i, 2) randomArr(i, 2) = randomArr(j, 2) randomArr(j, 2) = tempRow End If Next Next '根据排序后的行号复制原始数组到新数组 For i = LBound(arr, 1) To UBound(arr, 1) For j = LBound(arr, 2) To UBound(arr, 2) shuffledArr(i, j) = arr(randomArr(i - LBound(arr, 1) 1, 1), j) Next Next '返回打乱顺序后的新数组 ShuffleArray = shuffledArr End Function

代码解析：

（1）把数组乱序，达到随机抽取凭证的目的。

（2）如果觉得“不够随机”，可以多“随机”几次。

---End---

喜欢就点个赞、点在看、留个言呗！分享一下更给力！感谢！

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