《用ACCESS制作的会计记账程序》代码

时　间:2018-10-16 18:06:02
作　者:wangbohai   ID：69809  城市：北京
摘　要:这是一套实用的企业会计记账程序，它可以将流水账整理成科目汇总账和各科目总分类账，并能通过上年结转数计算出详尽的余额数据，与传统账本相差无几，基本上满足了会计工作的需要。
正　文:

《用ACCESS制作的会计记账程序》

这是一套实用的企业会计记账程序，它可以将流水账整理成科目汇总账和各科目总分类账，并能通过上年结转数计算出详尽的余额数据，与传统账本相差无几，基本上满足了会计工作的需要。只要电脑上有ACCESS就可以使用这个程序，没有其它限制。

本程序使用的都是极其简单的窗体SQL语言，代码完全公开，需要者可以根据需要进行改造。这套程序主要包括一个运算主程序和数据输入界面及若干窗口布置设计。

以下是运算主程序的代码，对ACCESS有所了解的人很容易通过它在窗口布置出文本框、按钮等匹配部分。记账凭证可以在ACCESS中录入，也可以导入EXCEL数据。建库的录入部分另有一个小小的程序，需要者请提出，也可以自行编制。

本程序虽检测成功，但仍有一些不足之处。由于时间的精力的有限，没有做进一步的精简、修饰和包装，仅供交流学习，抛砖引玉。粗糙之处敬请谅解，欢迎指错斧正。

王波海，2018年10月于北京。

 

 

Option Compare Database

Public b As String

Public c As String

Public d As String

Public e As String

Public k As String

Public y As String

Public rq As String

Public rq2 As String

Public km As String

Public jd As String

Public zy As String

Public ye As Variant

 

Private Sub Command0_Click() 

Dim SQL As String

Dim SQL2 As String

Dim SQL3 As String

Dim SQL4 As String

Dim SQL5 As String

Dim SQL6 As String

Dim SQL7 As String

Dim SQL8 As String

Dim SQL9 As String

Dim SQL10 As String

Dim SQL11 As String

Dim SQL12 As String

Dim SQL13 As String

Dim SQL14 As String

Dim SQL15 As String

Dim SQL16 As String

Dim SQL17 As String

Dim SQL18 As String

Dim SQL19 As String

Dim SQL20 As String

Dim SQL21 As String

Dim SQL22 As String

Dim drop1 As String

Dim drop2 As String

Dim drop3 As String

Dim drop4 As String

Dim drop5 As String

Dim qqs As String

Dim qqs1 As String

Dim qqs2 As String

Dim qqs3 As String

Dim qqs4 As String

 

 

Dim db As DAO.Database

Dim rs As DAO.Recordset

Dim fd As DAO.Field

Dim mykm1 As Variant

Dim mykm2 As Variant

Dim mykm3 As Variant

Dim mykm4 As Variant

Dim myjd1 As Variant

Dim myjd2 As Variant

Dim myjd3 As Variant

Dim myjd4 As Variant

 

'Dim myid(30) As Variant

Dim mysql As String

Dim kuming As String

'Dim km As String

Dim i As Integer

Dim j As Integer

Dim m As String

Dim eof1 As Integer

Dim zy1 As String

Dim rs2 As New ADODB.Recordset

Dim strSql As String

 

DoCmd.SetWarnings False

 

a = InputBox("输入年份", "输入年份窗口,默认=2017 ", "2017", 5000, 5000)

'Me!Text0.SetFocus

'Me!Text0.Value = a

a = CStr(a)

b = "01"

e = CStr(CDbl(b) - 1)

d = CStr(CDbl(b))

b = CStr(b)

c = a + b

rq = a + b

rq2 = rq - 1

 

km = InputBox("输入科目", "输入科目窗口默认=银行存款 ", "银行存款 ", 5000, 5000)

km = Trim(km)

'zcl = InputBox("是否为资产类科目（输入Y或者N）", "选择是否为资产类科目科目窗口（默认认=Y） ", "Y", 5000, 5000)

qqs = InputBox("输入上年" + km + "结转额", "输入上年结转额窗口,默认=0 ", "0 ", 5000, 5000)

jd = InputBox("上年结转额是借还是贷,j为借 d为贷 n为没有 ", "输入上年结转额借贷j/d/n窗口.默认=j", "j", 5000, 5000)

If MsgBox("是否继续？" & vbCrLf & "是=继续，否=退出", vbYesNo, "财务分类账") = vbNo Then

    Exit Sub

End If

  

qqs1 = "Select" + "[" + a + "]" + ".id" _

+ "," + "[" + a + "]" + ".日期" _

+ "," + "[" + a + "]" + ".顺序号" _

+ "," + "[" + a + "]" + ".摘要" _

+ " INTO " + a + "上年" + Trim(km) + "结转" _

+ " FROM " + a _

+ " Where 顺序号=999999"

 

 DoCmd.RunSQL qqs1

 qqs4 = "Insert INTO " + a + "上年" + Trim(km) + "结转 " _

   + "(摘要) values (' ')"

  DoCmd.RunSQL qqs4

  qqs2 = "alter table " + a + "上年" + Trim(km) + "结转 add 借方 money,贷方 money,借贷 char,余额 money"

   DoCmd.RunSQL qqs2

   qqs3 = "Update " + a + "上年" + Trim(km) + "结转 SET 摘要 = '上年结转'," _

    + "余额=" + qqs + ",顺序号 = rq-1" + ",借贷=jd"

    DoCmd.RunSQL qqs3

'MsgBox (rq & km & "上年结转完成,请继续。")

  '=================================================================

  For i = 1 To 12

SQL = "Select " + "[" + a + "]" + ".日期 " _

+ "," + "[" + a + "]" + ".顺序号 " _

+ "," + "[" + a + "]" + ".摘要 " _

+ "," + "[" + a + "]" + ".金额 " + "AS 借方 " _

+ "INTO " + a + "借方" + km _

+ " FROM " + a _

+ " Where (((" + " [" + a + "]" + ".借方科目)=" _

+ " '" + km + "'" + ")" _

+ " AND ((Month([日期]))=" + d + "))"

DoCmd.SetWarnings False

DoCmd.RunSQL SQL

SQL2 = "alter table " + a + "借方" + km + " add 贷方 money,借贷 char(4) ,余额 money"

 DoCmd.RunSQL SQL2

SQL2 = "Update " + a + "借方" + km + " SET 借贷 ='j'"

DoCmd.RunSQL SQL2

SQL3 = "Select " + "[" + a + "]" + ".日期 " _

+ "," + "[" + a + "]" + ".顺序号 " _

+ "," + "[" + a + "]" + ".摘要 " _

+ "," + "[" + a + "]" + ".金额 " + "AS 贷方 " _

+ "INTO " + a + "贷方" + km _

+ " FROM " + a _

+ " Where (((" + " [" + a + "]" + ".贷方科目)=" _

+ " '" + km + "'" + ")" _

+ " AND ((Month([日期]))=" + d + "))"

DoCmd.RunSQL SQL3

SQL4 = "alter table " + a + "贷方" + km + " add 借方 money,借贷 char(4) ,余额 money"

DoCmd.RunSQL SQL4

SQL4 = "Update " + a + "贷方" + km + " SET 借贷 ='d'"

DoCmd.RunSQL SQL4

SQL5 = "insert into " + a + "借方" + km + "(日期, 顺序号,摘要,贷方,借贷) select 日期,顺序号,摘要,贷方,借贷 from " + a + "贷方" + km

DoCmd.RunSQL SQL5

SQL6 = "Select Sum([" + a + "借方" + km + "].借方) AS 借方, Sum([" + a + "借方" + km + "].贷方) AS 贷方 INTO " + a + "借贷方" + km + "合计" + " FROM " + a + "借方" + km

DoCmd.RunSQL SQL6

SQL7 = "Insert INTO " + a + "借方" + km + "(借方,贷方,顺序号,摘要)" + " Select " + "借方, 贷方," + rq + ", '本月合计'" + " FROM " + a + "借贷方" + km + "合计"

 DoCmd.RunSQL SQL7

SQL8 = "Insert INTO " + a + "上年" + km + "结转(日期,借方, 贷方, 顺序号, 摘要) Select 日期,借方, 贷方, 顺序号, 摘要 FROM " + a + "借方" + km

DoCmd.RunSQL SQL8

SQL9 = "Select" + "[" + a + "上年" + km + "结转" + "]" + ".日期" _

+ "," + "[" + a + "上年" + km + "结转" + "]" + ".顺序号" _

+ "," + "[" + a + "上年" + km + "结转" + "]" + ".摘要" _

+ "," + "[" + a + "上年" + km + "结转" + "]" + ".借方" _

+ "," + "[" + a + "上年" + km + "结转" + "]" + ".贷方" _

+ "," + "[" + a + "上年" + km + "结转" + "]" + ".余额" _

+ " INTO " + a + km + "余额计算1" _

+ " FROM " + a + "上年" + km + "结转" _

+ " Where 顺序号=rq or 顺序号=rq-1"

DoCmd.RunSQL SQL9

SQL10 = "alter table " + a + km + "余额计算1 add 本月合计 money, 上月余额 money,借贷 char(4) "

DoCmd.RunSQL SQL10

SQL11 = "Update " + a + km + "余额计算1" + " SET 本月合计 = 借方 Where 顺序号=" + rq

'MsgBox (SQL11)

DoCmd.RunSQL SQL11

SQL12 = "Update " + a + km + "余额计算1" + " SET 贷方=0, 借方=0 Where 顺序号=rq - 1"

'MsgBox (SQL12)

DoCmd.RunSQL SQL12

SQL13 = "Select Sum([" + a + km + "余额计算1].借方) AS 借方," _

+ " Sum([" + a + km + "余额计算1].贷方) AS 贷方," _

+ " Sum([" + a + km + "余额计算1].余额) AS 余额," _

+ " Sum([" + a + km + "余额计算1].本月合计) AS 本月合计," _

+ " Sum([" + a + km + "余额计算1].上月余额) AS 上月余额" _

+ " INTO " + a + km + "余额计算2" _

+ " from " + a + km + "余额计算1"

'MsgBox (SQL13)

DoCmd.RunSQL SQL13

SQL14 = "alter table " + a + km + "余额计算2 add 顺序号 integer,借贷 char(4)"

'MsgBox (SQL14)

DoCmd.RunSQL SQL14

SQL15 = " Update " + a + km + "余额计算2 SET 上月余额=余额, 顺序号 = " + rq

'MsgBox (SQL15)

DoCmd.RunSQL SQL15

SQL16 = "Update " + a + km + "余额计算2 SET 本月合计 = 0 Where 本月合计 is null"

'MsgBox (SQL16)

DoCmd.RunSQL SQL16

SQL17 = "Update " + a + km + "余额计算2 SET 贷方= 0 Where 贷方 is null"

'MsgBox (SQL17)

DoCmd.RunSQL SQL17

SQL18 = "Update " + a + km + "余额计算2 SET 上月余额 = 0 Where 上月余额 is null"

'MsgBox (SQL18)

DoCmd.RunSQL SQL18

'If zcl = "Y" Then

'    SQL19 = "Update " + a + km + "余额计算2 SET 余额=上月余额+本月合计-贷方,借贷='j' where 顺序号 = " + rq

'

'Else

'

'    SQL19 = "Update " + a + km + "余额计算2 SET 余额=上月余额+贷方-本月合计,借贷='d' where 顺序号 = " + rq

'

'End If

'MsgBox (SQL19)

'DoCmd.RunSQL SQL19

'If zcl = "Y" Then

'    SQL20 = "Update " + a + km + "余额计算2 SET 借贷='d' where 顺序号 = " + rq + " and 余额<0"

'   Else

'   SQL20 = "Update " + a + km + "余额计算2 SET 借贷='j' where 顺序号 = " + rq + " and 余额<0"

'End If

'DoCmd.RunSQL SQL20

    SQL21 = "Update " + a + km + "余额计算2 SET 借贷=' 'where 顺序号 = " + rq + " and 余额=0"

DoCmd.RunSQL SQL21

SQL22 = "Update " + a + "上年" + km + "结转 AS a," + a + km + "余额计算2 AS b SET a.余额 = b.余额,a.借贷  = b.借贷 Where a.顺序号=b.顺序号"

'MsgBox (SQL22)

DoCmd.RunSQL SQL22

drop1 = "drop table " + a + "贷方" + km

drop2 = "drop table " + a + km + "余额计算1"

drop3 = "drop table " + a + km + "余额计算2"

drop4 = "drop table " + a + "借贷方" + km + "合计"

drop5 = "drop table " + a + "借方" + km

 

DoCmd.RunSQL drop1

DoCmd.RunSQL drop2

DoCmd.RunSQL drop3

DoCmd.RunSQL drop4

DoCmd.RunSQL drop5

d = d + 1

rq = CStr(CDbl(rq) + 1)

Next i

'MsgBox ("分类完成")

'If MsgBox("是否继续？" & vbCrLf & "是=继续，否=退出。", vbYesNo, "财务分类账") = vbNo Then

'Exit Sub

'Else

'DoCmd.Close

'End If

'---------------------------------------------------------

kuming = a + "上年" + km + "结转"

Set db = CurrentDb()

Set rs = db.OpenRecordset(kuming)

'Set fd = rs.Fields("借方")

DoCmd.SetWarnings False

'DoCmd.SetWarnings True

'mysql = "Update " + kuming + " SET 借贷='借' Where 借贷 = 'j' "

'DoCmd.RunSQL mysql

'mysql = "Update " + kuming + " SET 借贷='j' "

'DoCmd.RunSQL mysql

mysql = "Update " + kuming + " SET 借贷='n' Where 借贷 is null"

DoCmd.RunSQL mysql

mysql = "Update " + kuming + " SET 贷方= 0 Where 贷方 is null "

 

DoCmd.RunSQL mysql

mysql = "Update " + kuming + " SET 借方= 0 Where 借方 is null"

DoCmd.RunSQL mysql

mysql = "Update " + kuming + " SET 余额= 0 Where 余额 is null"

DoCmd.RunSQL mysql

mysql = "Update " + kuming + " SET 摘要= '无' Where 摘要 is null"

DoCmd.RunSQL mysql

mysql = "Update " + kuming + " SET 借贷='d' Where 贷方 <> 0"

DoCmd.RunSQL mysql

mysql = "Update " + kuming + " SET 借贷='j' Where 借方 <> 0"

DoCmd.RunSQL mysql

mysql = "Update " + kuming + " SET 借贷='n' Where 借方 = 0 and 贷方 = 0 and 余额 = 0"

DoCmd.RunSQL mysql

'MsgBox ("借贷方标识完成")

'If MsgBox("是否继续？" & vbCrLf & "是=继续，否=退出。", vbYesNo, "财务分类账") = vbNo Then

'    Exit Sub

'Else

'   DoCmd.Close

'End If

'---------------------------------------------------------------------------

k = 0

eof1 = rs.RecordCount - 1

'MsgBox ("eof1=" & eof1)

rs.MoveFirst

For i = 1 To eof1

mykm1 = rs.Fields("余额")

myjd1 = rs.Fields("借贷")

myjd1 = Trim(myjd1)

rs.MoveNext

mykm2 = rs.Fields("借方")

myjd2 = rs.Fields("借贷")

myjd2 = Trim(myjd2)

mykm3 = rs.Fields("贷方")

myjd3 = rs.Fields("借贷")

myjd3 = Trim(myjd3)

If myjd1 = "j" And myjd2 = "j" Then

     k = mykm1 + mykm2 - mykm3

     If k > 0 Then

       myjd4 = "j"

     End If

    

     If k < 0 Then

       myjd4 = "d"

       End If

 

     If k = 0 Then

       myjd4 = "n"

       k = 0

     End If

  k = Abs(k)

End If

 

If myjd1 = "j" And myjd2 = "d" Then

     k = mykm1 + mykm2 - mykm3

     If k > 0 Then

       myjd4 = "j"

     End If

    

     If k < 0 Then

       myjd4 = "d"

       End If

 

     If k = 0 Then

       myjd4 = "n"

       k = 0

     End If

  k = Abs(k)

End If

 

If myjd1 = "j" And myjd2 = "n" Then

     k = mykm1 + mykm2 - mykm3

     If k > 0 Then

       myjd4 = "j"

     End If

     If k < 0 Then

       myjd4 = "d"

       End If

 

     If k = 0 Then

       myjd4 = "n "

       k = 0

     End If

  k = Abs(k)

End If

 

If myjd1 = "d" And myjd2 = "d" Then

   k = mykm1 + mykm3 - mykm2

    If k > 0 Then

       myjd4 = "d"

    End If

    If k < 0 Then

       myjd4 = "j"

     End If

    If k = 0 Then

       myjd4 = "n"

       k = 0

    End If

 k = Abs(k)

 End If

If myjd1 = "d" And myjd2 = "j" Then

   k = mykm1 + mykm3 - mykm2

    If k > 0 Then

       myjd4 = "d"

    End If

    If k < 0 Then

       myjd4 = "j"

     End If

    If k = 0 Then

       myjd4 = "n"

       k = 0

    End If

 k = Abs(k)

 End If

 

 If myjd1 = "d" And myjd2 = "n" Then

   k = mykm1 + mykm3 - mykm2

    If k > 0 Then

       myjd4 = "d"

    End If

    If k < 0 Then

       myjd4 = "j"

     End If

    If k = 0 Then

       myjd4 = "n"

       k = 0

    End If

 k = Abs(k)

 End If

 

If myjd1 = "n" And myjd2 = "n" Then

   k = mykm1 + mykm2 - mykm3

    If k > 0 Then

       myjd4 = "n"

    End If

    If k < 0 Then

       myjd4 = "n"

    End If

   

    If k = 0 Then

       myjd4 = "n"

       k = 0

    End If

  k = Abs(k)

 End If

 

 If myjd1 = "n" And myjd2 = "d" Then

 

   k = mykm1 + mykm3 - mykm2

    If k < 0 Then

       myjd4 = "j"

    End If

   

    If k > 0 Then

       myjd4 = "d"

    End If

   

    If k = 0 Then

       myjd4 = "n"

    End If

  k = Abs(k)

 End If

 

 If myjd1 = "n" And myjd2 = "j" Then

   k = mykm1 + mykm2 - mykm3

    If k < 0 Then

       myjd4 = "d"

    End If

  

    If k > 0 Then

       myjd4 = "j"

    End If

   

    If k = 0 Then

       myjd4 = "n"

    End If

  k = Abs(k)

 End If

 

'rs.Edit

'zy1 = rs.Fields("id")

'MsgBox (zy1 & " : " & zy)

zy = rs.Fields("摘要")

 

If zy <> "本月合计" Then

   rs.Edit

   rs.Fields("余额") = k

   rs.Fields("借贷") = myjd4

   rs.Update

   k = 0

Else

 

   rs.MovePrevious

   ye = rs.Fields("余额")

   myjd4 = rs.Fields("借贷")

  

   rs.MoveNext

   rs.Edit

   rs.Fields("余额") = ye

   rs.Fields("借贷") = myjd4

   rs.Update

   k = 0

End If

 

Next

 

rs.Close

db.Close

Set rs = Nothing

Set db = Nothing

 

mysql = "Update " + kuming + " SET 借贷='n' Where 借方 = 0 and 贷方 = 0 and 余额 = 0"

DoCmd.RunSQL mysql

 

MsgBox (km & "科目明细分类账全部完成")

'a = InputBox("输入年份", "输入年份窗口,默认=2017 ", "2017", 5000, 5000)

a = Trim(a)

b = a

'km = InputBox("输入科目", "输入科目窗口默认=银行存款 ", "银行存款 ", 5000, 5000)

km = Trim(km)

c = km

km = a + "上年" + km + "结转"

kuming = Trim(km)

a = kuming

m = b + c + "总分类账"

 

''strSql = "select Name from MsysObjects where type=1 and Flags=0 and Name=" + "'" + a + "'"

 

'rs2.Open strSql, CurrentProject.Connection, adOpenStatic, adLockReadOnly

'If rs2.RecordCount < 1 Then

'    MsgBox a & "表不存在，请先建表。"

'    Exit Sub

'Else

'    MsgBox a & "表已经存在。"

'End If

 

qqs1 = "Select" + "[" + a + "]" + ".id" _

+ "," + "[" + a + "]" + ".日期" _

+ "," + "[" + a + "]" + ".顺序号" _

+ "," + "[" + a + "]" + ".摘要" _

+ "," + "[" + a + "]" + ".借方" _

+ "," + "[" + a + "]" + ".贷方" _

+ "," + "[" + a + "]" + ".借贷" _

+ "," + "[" + a + "]" + ".余额" _

+ " INTO " + m _

+ " FROM " + a _

+ " Where 摘要 = '上年结转'or 摘要 = '本月合计'"

DoCmd.RunSQL qqs1

 

qqs1 = "Select Sum([" + m + "].借方) AS 借方, Sum([" + m + "].贷方) AS 贷方, Sum([" + m + "].余额) AS 余额 INTO " + m + "合计" + " FROM " + m

'MsgBox qqs1, 4

DoCmd.RunSQL qqs1

qqs1 = "Insert INTO " + m + "(借方,贷方)" + " Select " + "借方,贷方 FROM " + m + "合计"

DoCmd.RunSQL qqs1

qqs1 = "Update " + m + " SET 摘要 = '本年合计' Where 摘要 is null"

DoCmd.RunSQL qqs1

drop1 = "drop table " + m + "合计"

DoCmd.RunSQL drop1

km = m + "合计"

Set rs = CurrentDb().OpenRecordset(m)

rs.MoveLast

rs.MovePrevious

mykm1 = rs.Fields("余额")

'MsgBox ("mykm1=" & mykm1)

rs.MoveLast

rs.Edit

rs.Fields("余额") = mykm1

rs.Update

rs.Close

MsgBox (m & "完成")

End Sub

'-----------------------------------------------------------------

Private Sub Command1_Click()

Dim akm As String

Dim sqlkm As String

Dim rs As New ADODB.Recordset

Dim strSql As String, strg As String

akm = InputBox("输入年份", "输入年份窗口,默认=2017 ", "2017", 5000, 5000)

'a = "2017"

sqlkm = "Select " + " [" + akm + "]" + ".借方科目" _

+ "," + "Count(" + " [" + akm + "]" + ".金额) AS 金额之计数" _

+ " INTO " + akm + "借方科目名称汇总" _

+ " FROM " + akm + " GROUP BY " + " [" + akm + "]" + ".借方科目 " _

+ "HAVING (((" + " [" + akm + "]" + ".借方科目)>'1')) "

 

DoCmd.SetWarnings False

DoCmd.RunSQL sqlkm

sqlkm = "Select " + " [" + akm + "]" + ".贷方科目" _

+ "," + "Count(" + " [" + akm + "]" + ".金额) AS 金额之计数" _

+ " INTO " + akm + "贷方科目名称汇总" _

+ " FROM " + akm + " GROUP BY " + " [" + akm + "]" + ".贷方科目 " _

+ "HAVING (((" + " [" + akm + "]" + ".贷方科目)>'1')) "

DoCmd.RunSQL sqlkm

'MsgBox ("借方科目名称汇总己生成")

'Me.Text4 = sqlkm

 

    strSql = "select 借方科目 from " + akm + "借方科目名称汇总"

    rs.Open strSql, CurrentProject.Connection, adOpenStatic, adLockReadOnly

    Do Until rs.EOF

        strg = strg & rs!借方科目 & vbCrLf

       ' MsgBox (strg)

        rs.MoveNext

   Loop

    Text4 = strg

    If rs.State = adStateOpen Then rs.Close

    Set rs = Nothing

   

  'MsgBox ("借方科目名称汇总己生成")

'Me.Text4 = sqlkm

   

  strSql = "select 贷方科目 from " + akm + "贷方科目名称汇总"

    rs.Open strSql, CurrentProject.Connection, adOpenStatic, adLockReadOnly

    Do Until rs.EOF

        strg = strg & rs!贷方科目 & vbCrLf

       ' MsgBox (strg)

       

        rs.MoveNext

   Loop

    Text6 = strg

    If rs.State = adStateOpen Then rs.Close

    Set rs = Nothing

End Sub

Private Sub Command2_Click()

'If MsgBox("是否继续？" & vbCrLf & "是=继续，否=退出。", vbYesNo, "财务分类账") = vbNo Then

'    Exit Sub

'Else

'   DoCmd.Close

'End If

End Sub

 

Private Sub Command3_Click()

MsgBox (" 该功能己并入分类汇总。" & vbCrLf & "做完科目分类汇总后自动形成科目总分类账.")

DoCmd.Close

Exit Sub

Dim db As DAO.Database

Dim rs As DAO.Recordset

Dim fd As DAO.Field

Dim mykm1 As Variant

Dim mykm2 As Variant

Dim mykm3 As Variant

Dim mykm4 As Variant

Dim myjd1 As Variant

Dim myjd2 As Variant

Dim myjd3 As Variant

Dim myjd4 As Variant

Dim mysql As String

Dim kuming As String

Dim km As String

Dim i As Integer

Dim j As Integer

Dim m As String

Dim eof1 As Integer

Dim zy1 As String

Dim rs2 As New ADODB.Recordset

Dim strSql As String

DoCmd.SetWarnings False

'---------------------------------------------------------

a = InputBox("输入年份", "输入年份窗口,默认=2017 ", "2017", 5000, 5000)

a = Trim(a)

b = a

km = InputBox("输入科目", "输入科目窗口默认=银行存款 ", "银行存款 ", 5000, 5000)

km = Trim(km)

c = km

km = a + "上年" + km + "结转"

kuming = Trim(km)

a = kuming

m = b + c + "总分类账"

 

strSql = "select Name from MsysObjects where type=1 and Flags=0 and Name=" + "'" + a + "'"

rs2.Open strSql, CurrentProject.Connection, adOpenStatic, adLockReadOnly

If rs2.RecordCount < 1 Then

    MsgBox a & "表不存在，请先建表。"

    Exit Sub

Else

    MsgBox a & "表已经存在。"

End If

qqs1 = "Select" + "[" + a + "]" + ".id" _

+ "," + "[" + a + "]" + ".日期" _

+ "," + "[" + a + "]" + ".顺序号" _

+ "," + "[" + a + "]" + ".摘要" _

+ "," + "[" + a + "]" + ".借方" _

+ "," + "[" + a + "]" + ".贷方" _

+ "," + "[" + a + "]" + ".借贷" _

+ "," + "[" + a + "]" + ".余额" _

+ " INTO " + m _

+ " FROM " + a _

+ " Where 摘要 = '上年结转'or 摘要 = '本月合计'"

DoCmd.RunSQL qqs1

qqs1 = "Select Sum([" + m + "].借方) AS 借方, Sum([" + m + "].贷方) AS 贷方, Sum([" + m + "].余额) AS 余额 INTO " + m + "合计" + " FROM " + m

'MsgBox qqs1, 4

DoCmd.RunSQL qqs1

qqs1 = "Insert INTO " + m + "(借方,贷方)" + " Select " + "借方,贷方 FROM " + m + "合计"

DoCmd.RunSQL qqs1

qqs1 = "Update " + m + " SET 摘要 = '本年合计' Where 摘要 is null"

DoCmd.RunSQL qqs1

drop1 = "drop table " + m + "合计"

DoCmd.RunSQL drop1

km = m + "合计"

Set rs = CurrentDb().OpenRecordset(m)

rs.MoveLast

rs.MovePrevious

mykm1 = rs.Fields("余额")

'MsgBox ("mykm1=" & mykm1)

rs.MoveLast

rs.Edit

rs.Fields("余额") = mykm1

rs.Update

rs.Close

MsgBox (m & "完成")

End Sub

Access软件网官方交流QQ群 (群号:54525238) 　　　　　　Access源码网店