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

jsgj2023 · 发表于 2019-1-17 11:03

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

模块2.会计凭证

Public dic As Object '三级科目
Public dicAbstract As Object '摘要
Public dicSumAccount As Object '总账科目
Public dicSecondarySubject As Object '二级科目
Sub 会计科目存为数组()
Dim data As New data查询
Dim SQL As String
Dim arr, y
Set dic = CreateObject("scripting.dictionary")
Set dicAbstract = CreateObject("scripting.dictionary")
Set dicSumAccount = CreateObject("scripting.dictionary")
Set dicSecondarySubject = CreateObject("scripting.dictionary")
SQL = "Select * from 科目维护"
arr = data.筛选结果(SQL)
For y = 0 To UBound(arr, 2)
dic(UCase(arr(2, y))) = ""
dicAbstract(UCase(arr(4, y))) = ""
dicSumAccount(UCase(arr(1, y))) = ""
dicSecondarySubject(UCase(arr(0, y))) = ""
Next y
End Sub

复制代码

jsgj2023 · 发表于 2019-1-17 11:04

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

模块3.凭证录入

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)
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 '当前凭证号
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-17 11:10

本帖最后由 jsgj2023 于 2019-1-18 08:41 编辑

模块4.填表助手

Public UserInput As Boolean
Public txt
Public Sub 初始化切换按键()
On Error Resume Next
Application.MacroOptions Macro:="输入状态切换", Description:="切换输入形式", ShortcutKey:="e"
End Sub
Public Sub 输入状态切换()
UserInput = Not UserInput
If UserInput Then
s = "关闭列表辅助输入状态!"
ActiveSheet.TextBox1.Visible = False
ActiveSheet.ListBox1.Visible = False
Else
s = "打开列表辅助输入状态!"
End If
MsgBox s
End Sub

复制代码

jsgj2023 · 发表于 2019-1-17 11:11

本帖最后由 jsgj2023 于 2019-1-18 08:43 编辑

以上为模块下的代码,接下来是类模块下的代码,共4个,名称分别为:Data查询金额本月合计和本年累计金额合计日记账的合计与累计

jsgj2023 · 发表于 2019-1-17 11:13

本帖最后由 jsgj2023 于 2019-1-18 08:44 编辑

类模块1.Data查询

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)
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

复制代码

jsgj2023 · 发表于 2019-1-17 11:26

本帖最后由 jsgj2023 于 2019-1-18 08:45 编辑

类模块2.金额本月合计与本年累计

Function theMonthTotal_CurrentYearCumulative() '本月合计本年累计 the month total current year cumulative
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

复制代码

jsgj2023 · 发表于 2019-1-17 11:28

本帖最后由 jsgj2023 于 2019-1-18 08:56 编辑

类模块3.金额合计

Function 日记账金额合计(initialBalance As Double)
With ActiveSheet
intRow = .Cells(Rows.Count, 1).End(xlUp).Row
intCol = .Cells(intRow, Columns.Count).End(xlToLeft).Column
arr = .Range(.Cells(2, 4), .Cells(intRow, intCol))
a = Application.Sum(Application.Index(arr, , 1))
b = Application.Sum(Application.Index(arr, , 2))
.Cells(intRow + 1, 4) = a
.Cells(intRow + 1, intCol) = b
.Cells(intRow + 1, intCol + 1) = a + initialBalance - b
.Cells(intRow + 1, intCol - 2) = "合计"
End With
End Function
Function 应收明细查询合计()
With ActiveSheet
intRow = .Cells(Rows.Count, 1).End(xlUp).Row
intCol = .Cells(intRow, Columns.Count).End(xlToLeft).Column
arr = .Range(.Cells(2, 4), .Cells(intRow, intCol))
a = Application.Sum(Application.Index(arr, , 1))
b = Application.Sum(Application.Index(arr, , 2))
c = Application.Sum(Application.Index(arr, , 3))
.Cells(intRow + 1, 4) = a
.Cells(intRow + 1, 5) = b
.Cells(intRow + 1, 6) = a - b
.Cells(intRow + 1, intCol - 3) = "合计"
End With
End Function
Function 应付明细查询合计()
With ActiveSheet
intRow = .Cells(Rows.Count, 1).End(xlUp).Row
intCol = .Cells(intRow, Columns.Count).End(xlToLeft).Column
arr = .Range(.Cells(2, 4), .Cells(intRow, intCol))
a = Application.Sum(Application.Index(arr, , 1))
b = Application.Sum(Application.Index(arr, , 2))
c = Application.Sum(Application.Index(arr, , 3))
.Cells(intRow + 1, 4) = a
.Cells(intRow + 1, 5) = b
.Cells(intRow + 1, 6) = b - a
.Cells(intRow + 1, intCol - 3) = "合计"
End With
End Function
Function 应收_付账款汇总查询合计()
With ActiveSheet
intRow = .Cells(Rows.Count, 1).End(xlUp).Row
intCol = .Cells(intRow, Columns.Count).End(xlToLeft).Column
arr = .Range(.Cells(2, 2), .Cells(intRow, intCol))
a = Application.Sum(Application.Index(arr, , 1))
.Cells(intRow + 1, 2) = a
.Cells(intRow + 1, 1) = "合计"
End With
End Function

复制代码

jsgj2023 · 发表于 2019-1-17 11:30

本帖最后由 jsgj2023 于 2019-1-18 10:29 编辑

类模块4.日记账合计与累计

Function dayBook_theMonthTotal_CurrentYearCumulative(initialBalance As Double) '日记账本月合计本年累计 the month total current year cumulative
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:h" & r)
'*************在第一行添加上年结转余额********************
For j = 2 To UBound(arr)
If j = 2 Then Cells(j, 8) = Cells(j, 8) + initialBalance: Exit For
Next
'*************在第一行添加上年结转余额********************
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

复制代码

jsgj2023 · 发表于 2019-1-17 11:33

本帖最后由 jsgj2023 于 2019-1-18 10:53 编辑

表格交互部分全部分享完毕,接下来分享数据库部分!

jsgj2023 · 发表于 2019-1-17 11:38

本帖最后由 jsgj2023 于 2019-1-18 11:16 编辑

1.负债类科目归集数据表

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

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