[e殿云]系列之Access财务记账管理系统

jsgj2023 · 发表于 2019-1-16 11:41

本帖最后由 jsgj2023 于 2019-1-19 14:43 编辑

最近因实际工作需要,写了个财务记账管理系统,本系统为本人结合实际工作需要编写,能极大地优化财税工作流程,提高工作效率,共分为2个部分:第一部分:表格交互;第二部分:数据库;表格交互部分共13个模块,一个模块占用一张表格,代码一般都在对应工作表下,函数过程和类模块需另建模块和类模块,13大模块分别为: 1.凭证录入 2.单笔凭证查询和删除 3.凭证批量查询 4.应收账款明细查询 5.应收账款汇总查询 6.应付账款明细查询 7.应付账款汇总查询 8.试算平衡 9.会计科目汇总表 10.成本利润核算 11.银行日记账 12.现金日记账 13.税收筹划; 数据库部分因涉及单位商业机密,仅分享代码及数据库结构,如有需要请自行按照本篇文章设计部署,在实施过程中如碰到问题或有建议请联系本人!

jsgj2023 · 发表于 2019-1-16 11:52

本帖最后由 jsgj2023 于 2019-1-17 10:24 编辑

Sub 凭证录入()

复制代码

Dim arr, arr1, x As Integer, mydate As Date, hm As String, sr As String, SQL As String
Dim mydata As New data查询
With Sheets("凭证录入")
mydate = .[C3]: hm = .[f3]
If mydata.是否存在("和美贸易", "凭证号", hm) = True Or Len(Range("a5")) = 0 Then
MsgBox "该凭证已存在或没有数据，请不要重复录入并添加数据!"
Exit Sub
Else
r = .Cells(Rows.Count, 2).End(xlUp).Row - 2
arr = .Range("a5:f" & r)
'b = 借贷平衡检查(arr)
If 借贷平衡检查(arr) Then
For x = 1 To UBound(arr)
If Len(arr(x, 2)) Then
arr(x, 3) = IIf(IsEmpty(arr(x, 3)), 0, arr(x, 3))
arr(x, 4) = IIf(IsEmpty(arr(x, 4)), 0, arr(x, 4))
arr(x, 5) = IIf(IsEmpty(arr(x, 5)), 0, arr(x, 5))
arr(x, 6) = IIf(IsEmpty(arr(x, 6)), 0, arr(x, 6))
sr = "#" & mydate & "#" & ",'" & hm & "','" & arr(x, 1) & "','" & arr(x, 2) & "','"
sr = sr & arr(x, 3) & "','" & arr(x, 4) & "'," & Round(arr(x, 5), 2) & "," & arr(x, 6)
SQL = "Insert into 和美贸易 (记账日期, 凭证号, 摘要,总账科目,二级科目,三级科目,借方金额,贷方金额) VALUES(" & sr & ")"
mydata.执行sql命令 (SQL)
End If
Next x
Call 清空已录数据及凭证号
MsgBox "成功录入数据库"
Else
MsgBox "借贷不平衡,请检查!"
Exit Sub
End If
End If
End With
End Sub
Function 借贷平衡检查(arr) As Boolean
Dim a As Single
Dim b As Single
a = Application.Sum(Application.Index(arr, , 5))
b = Application.Sum(Application.Index(arr, , 6))
If a <> b Then
借贷平衡检查 = False
Else
借贷平衡检查 = True
End If
End Function
Sub 清空已录数据及凭证号()
Dim currentNum As Integer '当前凭证号
'Current certificate number 当前凭证号
With Sheets("凭证录入")
r = .Cells(Rows.Count, 1).End(xlUp).Row - 2 - 4
.Range("a5").Resize(r, 6).ClearContents
currentNum = .Range("f3")
currentNum = currentNum + 1
.Range("f3") = currentNum
End With
End Sub

复制代码

本段代码放在模块[凭证录入]下

jsgj2023 · 发表于 2019-1-16 11:53

本帖最后由 jsgj2023 于 2019-1-17 10:25 编辑

1.凭证录入

jsgj2023 · 发表于 2019-1-16 12:16

本帖最后由 jsgj2023 于 2019-1-17 14:44 编辑

Public recordColumnNo As Integer '记录列号
'=================填表助手===============
Option Compare Text
Private Const LowBound = 1 '设定执行智能匹配时输入字符串的最小长度，以便减少无意义的匹配动作
Private rDataS As Long
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Call 输入
End Sub
Private Sub TextBox1_Change()
txt = Me.TextBox1.Text
End Sub
Private Sub TextBox1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim i As Integer
Select Case KeyCode
Case vbKeyE 'ctr+e切换输入状态
If Shift = 2 Then Call 填表助手.输入状态切换
Case vbKeyDelete '按delete键，则清空输入框及活动单元格
ActiveCell = ""
TextBox1.Text = ""
ListBox1.Clear
txt = ""
Case Else
Call SmartCompletion
End Select
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If UserInput Then Exit Sub
With Target
' If .Count > 1 Or .Column <> 8 Or .Row < 2 Then ZoomOut: Exit Sub '调整数据输入列
If .Column <> 1 And .Column <> 2 And .Column <> 3 And .Column <> 4 Or .Row < 5 Or .Row > 12 Then ZoomOut: Exit Sub '会计科目
recordColumnNo = .Column '记录列号
If .Count > 1 And .Row < 5 Or .Row > 12 Then ZoomOut: Exit Sub
L = .Left
t = .Top
w = .Width
h = .Height + 2
s = .Font.Size - 1
End With
With Me.TextBox1
.Left = L
.Top = t
.Width = w
.Height = h
.Font.Size = s
.Visible = True
.Text = ""
.Activate
End With
With Me.ListBox1
.Left = L
.Width = w
.Top = t + h + 2
.Height = h * 10
.Font.Size = s
.Clear
.Visible = True
End With
End Sub
Private Function ZoomOut()
Application.ScreenUpdating = False
With Me.ListBox1
.Width = 0
.Height = 0
.Visible = False
.Clear
End With
With Me.TextBox1 '
.Width = 0
.Height = 0
.Visible = False
.Text = ""
End With
Application.ScreenUpdating = True
End Function
'Public Dic As Object '三级科目
'Public dicAbstract As Object '摘要
'Public dicSumAccount As Object '总账科目
'Public dicSecondarySubject As Object '二级科目
Private Sub SmartCompletion() '自动完成
Dim s As String
Dim strKey As Variant
Dim cnn As Object, SQL As String, arr, brr(), i&, j&
Dim DataSource(1 To 65536, 1 To 1)
Application.ScreenUpdating = False
Call 会计凭证.会计科目存为数组
If recordColumnNo = 1 Then '摘要
strKey = dicAbstract.keys
For x = 0 To dicAbstract.Count - 1
k = k + 1
DataSource(k, 1) = strKey(x)
Next
ElseIf recordColumnNo = 2 Then '总账科目
strKey = dicSumAccount.keys
For x = 0 To dicSumAccount.Count - 1
k = k + 1
DataSource(k, 1) = strKey(x)
Next
ElseIf recordColumnNo = 3 Then '二级科目
strKey = dicSecondarySubject.keys
For x = 0 To dicSecondarySubject.Count - 1
k = k + 1
DataSource(k, 1) = strKey(x)
Next
Else '三级科目
strKey = dic.keys
For x = 0 To dic.Count - 1
k = k + 1
DataSource(k, 1) = strKey(x)
Next
End If
Application.ScreenUpdating = True
If Len(txt) < LowBound Then Exit Sub
s = "*" & UCase(TextBox1.Text) & "*"
With ListBox1
.Clear
rDataS = UBound(DataSource)
On Error Resume Next
For i = 1 To rDataS '
If DataSource(i, 1) Like s Then .AddItem DataSource(i, 1)
Next
If .ListCount = 0 Then
.Clear
.ListIndex = -1
Else
.ListIndex = 0
End If
.Height = ActiveCell.Height * IIf(.ListCount > 20, 20, 10)
End With
End Sub
Private Sub 输入()
If ListBox1.ListCount = 0 Then Exit Sub
ReDim Arraylist(0 To ListBox1.ListCount - 1, 0)
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = True Then
n = n + 1
Arraylist(n - 1, 0) = ListBox1.List(i)
End If
Next
If n > 0 Then ActiveCell.Resize(n, 1) = Arraylist '如果有选中的项，则把它输入工作表中
ActiveCell.Offset(n).Select
End Sub

复制代码

放在[凭证录入]工作表下,

jsgj2023 · 发表于 2019-1-16 13:40

类模块1下的代码:
类模块

Function 筛选结果(sq As String)
Dim conn As Object
Dim rst As Object
Set conn = CreateObject("adodb.connection")
Set rst = CreateObject("ADODB.Recordset")
conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "/Database/会计凭证.mdb"
Set rst = conn.Execute(sq)
筛选结果 = rst.GetRows
conn.Close
Set conn = Nothing
End Function
Sub 执行sql命令(sq As String)
Dim conn As Object
Dim rst As Object
Set conn = CreateObject("adodb.connection")
Set rst = CreateObject("ADODB.Recordset")
conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "/Database/会计凭证.mdb"
conn.Execute (sq)
conn.Close
Set conn = Nothing
End Sub
Function 是否存在(ku As String, zd As String, zh As String) 'ku指定查找的表,zd是判断的字段,zh 是值
Dim conn As Object
Dim rst As Object
Set conn = CreateObject("adodb.connection")
Set rst = CreateObject("ADODB.Recordset")
Dim SQL As String, arr
conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "/Database/会计凭证.mdb"
SQL = "Select * from " & ku & " where " & zd & "='" & zh & "'"
rst.Open SQL, conn, 1, 1
If rst.RecordCount = 0 Then
是否存在 = False
Else
是否存在 = True
End If
conn.Close
Set rst = Nothing
Set conn = Nothing
End Function
Sub 执行筛选(sq, rg As String)
Dim conn As Object
Set conn = CreateObject("adodb.connection")
With ActiveSheet
conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "/Database/会计凭证.mdb"
.Range(rg).CopyFromRecordset conn.Execute(sq)
arrgetsource = conn.Execute(sq).GetRows
End With
conn.Close
Set conn = Nothing
End Sub

复制代码

名称为[Data查询]

jsgj2023 · 发表于 2019-1-16 13:42

ThisWorkbook下的代码:

Private Sub Workbook_Open()
Call 初始化切换按键
Call 辅助查询.获取当前日期最后一笔凭证号码
MsgBox "智能提示功能已经启用。" & Chr(10) & Chr(10) & _
"您可以再次按 Ctrl+E 组合键来切换" & Chr(10) & _
"智能提示功能的启用或关闭状态。", vbInformation, "温馨提示："
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.DisplayAlerts = False
ThisWorkbook.Save
Application.DisplayAlerts = True
End Sub

复制代码

jsgj2023 · 发表于 2019-1-16 13:49

以上代码为实现凭证录入功能!

jsgj2023 · 发表于 2019-1-16 13:52

2.单笔凭证查询和删除

Sub 查询下一张凭证()
Dim ControlClicks As Long
Dim currentNum As Long
Dim demandNum As String
Dim mydata As New data查询
Dim SQL As String
Dim num As String
With Me
.Range("a5").Resize(6, 6) = ""
currentNum = .[f3]
ControlClicks = ControlClicks + 1
demandNum = currentNum + ControlClicks
If mydata.是否存在("和美贸易", "凭证号", demandNum) = False Then
MsgBox "该凭证号不存在!"
Exit Sub
Else
SQL = "Select * from 和美贸易 Where 凭证号=" & "'" & demandNum & "'" & " "
sql2 = "select t1.摘要,t1.总账科目,t1.二级科目,t1.三级科目,t1.借方金额,t1.贷方金额 from (" & SQL & ") as t1 "
sql3 = "Select DISTINCT 记账日期 from 和美贸易 Where 凭证号=" & "'" & demandNum & "'" & " "
mydata.执行筛选 sql2, "a5"
mydata.执行筛选 sql3, "c3" '记账日期
End If
.[f3] = demandNum
End With
End Sub
Sub 查询上一张凭证()
Dim ControlClicks As Long
Dim currentNum As Long
Dim demandNum As String
Dim mydata As New data查询
Dim SQL As String
Dim num As String
With Me
.Range("a5").Resize(6, 6) = ""
currentNum = .[f3]
ControlClicks = ControlClicks - 1
demandNum = currentNum + ControlClicks
If mydata.是否存在("和美贸易", "凭证号", demandNum) = False Then
MsgBox "该凭证号不存在!"
Exit Sub
Else
SQL = "Select * from 和美贸易 Where 凭证号=" & "'" & demandNum & "'" & " "
sql2 = "select t1.摘要,t1.总账科目,t1.二级科目,t1.三级科目,t1.借方金额,t1.贷方金额 from (" & SQL & ") as t1 "
sql3 = "Select DISTINCT 记账日期 from 和美贸易 Where 凭证号=" & "'" & demandNum & "'" & " "
mydata.执行筛选 sql2, "a5"
mydata.执行筛选 sql3, "c3" '记账日期
End If
.[f3] = demandNum
End With
End Sub
Sub 按凭证号查询凭证()
Dim mydata As New data查询
Dim SQL As String
Dim num As String
With Me
.Range("a5").Resize(6, 6) = ""
num = .[f3]
If mydata.是否存在("和美贸易", "凭证号", num) = False Then
MsgBox "该凭证号不存在!"
Exit Sub
Else
'& "','" & arr(x, 4) & "'"
SQL = "Select * from 和美贸易 Where 凭证号=" & "'" & num & "'" & " "
sql2 = "select t1.摘要,t1.总账科目,t1.二级科目,t1.三级科目,t1.借方金额,t1.贷方金额 from (" & SQL & ") as t1 "
sql3 = "Select DISTINCT 记账日期 from 和美贸易 Where 凭证号=" & "'" & num & "'" & " "
mydata.执行筛选 sql2, "a5"
mydata.执行筛选 sql3, "c3" '记账日期
End If
End With
End Sub
Sub 凭证修改()
Dim arr, arr1, x As Integer, mydate As Date, hm As String, sr As String, SQL As String
Dim mydata As New data查询
Call Me.按凭证号删除凭证
With Me
If Len(.Range("c5")) Then
mydate = .[C3]: hm = .[f3]
' If mydata.是否存在("和美贸易", "凭证号", hm) = True Then
' MsgBox "该凭证号已存在!"
' Exit Sub
' Else
r = .Cells(Rows.Count, 2).End(xlUp).Row - 2
arr = .Range("a5:f" & r)
'b = 借贷平衡检查(arr)
If 凭证录入.借贷平衡检查(arr) Then
For x = 1 To UBound(arr)
If Len(arr(x, 2)) Then
arr(x, 3) = IIf(IsEmpty(arr(x, 3)), 0, arr(x, 3))
arr(x, 4) = IIf(IsEmpty(arr(x, 4)), 0, arr(x, 4))
arr(x, 5) = IIf(IsEmpty(arr(x, 5)), 0, arr(x, 5))
arr(x, 6) = IIf(IsEmpty(arr(x, 6)), 0, arr(x, 6))
sr = "#" & mydate & "#" & ",'" & hm & "','" & arr(x, 1) & "','" & arr(x, 2) & "','"
sr = sr & arr(x, 3) & "','" & arr(x, 4) & "'," & Round(arr(x, 5), 2) & "," & arr(x, 6)
SQL = "Insert into 和美贸易 (记账日期, 凭证号, 摘要,总账科目,二级科目,三级科目,借方金额,贷方金额) VALUES(" & sr & ")"
mydata.执行sql命令 (SQL)
End If
Next x
'Call 清空已录数据及凭证号
MsgBox "成功修改数据并录入!"
Else
MsgBox "借贷不平衡,请检查!"
Exit Sub
End If
'End If
Else
MsgBox "没有数据!"
End If
End With
End Sub
Sub 按凭证号删除凭证()
Dim data As New data查询, SQL As String
With Me
If data.是否存在("和美贸易", "凭证号", .[f3]) = False Then
MsgBox "此凭证号不存在!"
Exit Sub
Else
SQL = "Delete from 和美贸易 where 凭证号='" & [f3] & "'"
data.执行sql命令 SQL
MsgBox "已删除凭证号为" & [f3] & "的凭证!"
End If
End With
End Sub

复制代码

jsgj2023 · 发表于 2019-1-16 13:59

Sub 凭证批量查询()
Dim mydata As New data查询
Dim SQL As String
Dim yearInt As Variant
Dim monthInt As Variant
Dim dataStr As Variant
On Error GoTo ErrMsg
With Me
.Range("a2:i65536") = ""
yearInt = "'" & .[O1] & "'"
monthInt = "'" & .[Q1] & "'"
dataStr = yearInt & "-" & monthInt
If .Range("N1") <> "年度" Then MsgBox "日期位置错误,请确保N列为年度字段,P列为月份字段!": Exit Sub
If Len(Range("O1")) = 0 Then MsgBox "请选择年度!": Exit Sub
If Len(Range("Q1")) <> 0 Then
SQL = "Select 记账日期,凭证号,摘要,总账科目,二级科目,三级科目,借方金额,贷方金额 from 和美贸易 where year(记账日期)= " & yearInt & " and month(记账日期)= " & monthInt & "order by 凭证号"
mydata.执行筛选 SQL, "a2"
Else
SQL = "Select 记账日期,凭证号,摘要,总账科目,二级科目,三级科目,借方金额,贷方金额 from 和美贸易 where year(记账日期)= " & yearInt & "order by 凭证号"
mydata.执行筛选 SQL, "a2"
End If
End With
Exit Sub
ErrMsg:
MsgBox Err.Description, , "错误报告"
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 17 Or Target.Column = 15 And Target.Row = 1 Then
Call Me.凭证批量查询
End If
End Sub

复制代码

3.凭证批量查询

jsgj2023 · 发表于 2019-1-16 14:04

4.应收账款明细查询

工作表下代码:
Sub 应收账款明细查询()
Dim mydata As New data查询
Dim SQL As String
Dim customerName As String
Application.ScreenUpdating = False
With Me
.Range("a2:h65536").ClearContents
customerName = "'" & .[k1] & "'"
If Len(Range("Q1")) > 0 And Len(Range("K1")) > 0 Then
datewhere = "year(记账日期) & month(记账日期) <=" & [O1] & [Q1] & ""
SQL = "Select 记账日期,year(记账日期) as 年,month(记账日期) as 月,凭证号,摘要,借方金额,贷方金额 ,(借方金额-贷方金额) as 余额 from 和美贸易 where ( " & datewhere & " ) and 总账科目='应收账款' and 二级科目=" & customerName & " order by 记账日期 "
ElseIf Len(Range("Q1")) = 0 And Len(Range("K1")) = 0 Then
datewhere = "year(记账日期) <=" & [O1] & ""
SQL = "Select 记账日期,year(记账日期) as 年,month(记账日期) as 月,凭证号,摘要,借方金额,贷方金额 ,(借方金额-贷方金额) as 余额 from 和美贸易 where ( " & datewhere & " ) and 总账科目='应收账款' order by 记账日期 "
ElseIf Len(Range("Q1")) = 0 And Len(Range("K1")) > 0 Then
datewhere = "year(记账日期) <=" & [O1] & ""
SQL = "Select 记账日期,year(记账日期) as 年,month(记账日期) as 月,凭证号,摘要,借方金额,贷方金额 ,(借方金额-贷方金额) as 余额 from 和美贸易 where ( " & datewhere & " ) and 总账科目='应收账款' and 二级科目=" & customerName & " order by 记账日期 "
Else
MsgBox "您组合有误,请重新选择!"
Exit Sub
End If
mydata.执行筛选 SQL, "a2"
Dim 计算本月合计和本年累计 As New 金额本月合计与本年累计
Call 计算本月合计和本年累计.theMonthTotal_CurrentYearCumulative
End With
Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 17 Or Target.Column = 11 And Target.Row = 1 Then
Call Me.应收账款明细查询
End If
End Sub
'( " & datewhere & " ) and
'and 摘要 not like '结转上年余额'
'Dim totalAmount As New 金额合计
'Call totalAmount.应收明细查询合计
类模块下代码:
Function theMonthTotal_CurrentYearCumulative() '本月合计本年累计 the month total current year cumulative
'With Sheets("应收账款明细查询")
With ActiveSheet
Dim d As Object
Dim dRow As Object
Dim dRowTotal As Object
Dim arr As Variant
Dim r&, x&, y&, z&
Set d = CreateObject("scripting.dictionary") '金额
Set dRow = CreateObject("scripting.dictionary") '本月小计行号
Set dRowTotal = CreateObject("scripting.dictionary") '本年累计行号
r = .Cells(Rows.Count, 1).End(xlUp).Row
arr = .Range("a1:f" & r)
For x = UBound(arr) To 3 Step -1
If Month(arr(x, 1)) <> Month(arr(x - 1, 1)) Then
.Rows(x).Insert
.Cells(x, 5) = "本年累计"
.Rows(x).Insert
.Cells(x, 5) = "本月小计"
End If
Next
' 末尾写入本年累计和本月小计字段
r = .Cells(.Rows.Count, 3).End(xlUp).Row
yy = .Cells(r, 3)
i = r
Do While .Cells(i, 3) = yy
i = i - 1
Loop
.Cells(r + 1, 5) = "本月小计"
.Cells(r + 2, 5) = "本年累计"
Dim arrInserted As Variant
r = .Cells(.Rows.Count, 5).End(xlUp).Row
'重新获取表格数据并写入数组
arr1 = .Range("a1:h" & r)
For x = 2 To UBound(arr1)
If arr1(x, 5) = "本月小计" Then dRow(x) = ""
If arr1(x, 5) = "本年累计" Then
n = n + 1
dRowTotal(x) = n
End If
If Len(arr1(x, 3)) Then
If Not d.exists(arr1(x, 3)) Then
d(arr1(x, 3)) = Array(arr1(x, 6), arr1(x, 7), arr1(x, 8))
Else
k = d(arr1(x, 3))
k(0) = k(0) + arr1(x, 6)
k(1) = k(1) + arr1(x, 7)
k(2) = k(2) + arr1(x, 8)
d(arr1(x, 3)) = k
End If
End If
Next
Dim strdItems As Variant
Dim strdRowKeys As Variant
strdItems = d.items
strdRowKeys = dRow.keys
For z = 0 To d.Count - 1
.Cells(strdRowKeys(z), 6).Resize(1, 3) = Application.Transpose(Application.Transpose(strdItems(z))) '本月合计
Next
'求本年累计
Dim sMonth As Variant
strdtotalitems = dRowTotal.items
strdtotalKeys = dRowTotal.keys
For i = 0 To dRowTotal.Count - 1
'借方金额
s = strdtotalitems(i)
sMonth = Application.Index(strdItems, , 1)
.Cells(strdtotalKeys(i), 6) = MonthlySum(s1, sMonth)
'贷方金额
sMonth = Application.Index(strdItems, , 2)
.Cells(strdtotalKeys(i), 7) = MonthlySum(s2, sMonth)
'余额
sMonth = Application.Index(strdItems, , 3)
.Cells(strdtotalKeys(i), 8) = MonthlySum(s, sMonth)
Next
End With
End Function
Function MonthlySum(strMonth, arr)
For x = 1 To strMonth
sSum = sSum + arr(x, 1)
Next
MonthlySum = sSum
End Function

复制代码

		自动登录	找回密码
密码			免费注册

[原创] [e殿云]系列之Access财务记账管理系统

评分

评分