本文于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活学活用，更多文章敬请关注！
