自动生成本月合计和累计

hzruziniu

zgjijinbao 发表于 2020-7-9 00:48
老师你好！还得麻烦你了，我的余额最终结果显示E-14，能不能把显示为0啊！实际也是0，有浮点

1. Dim k&, arr, brr(1 To 1000, 1 To 12)
   
2. Dim mD数#, mD额#, mC数#, mC额#, yD数#, yD额#, yC数#, yC额#
   
3. 
   
4. Sub 明细账查询()
   
5.     Dim i&, no$, j%
   
6.     Range("b8:i1500").ClearContents                '清除数据区
   
7.     Range("b8:i1500").Borders.LineStyle = xlNone   '清除网格线
   
8.     Range("b8:i1500").Interior.Pattern = xlNone             '删除底色
   
9.     no = Range("d4")               '科目代码定义为no
   
10.     arr = Sheets("凭证明细表").Range("a2：j" & Sheets("凭证明细表").Range("a20000").End(3).Row) '.CurrentRegion  '分录源表装入数组arr
    
11.     k = 0
    
12.     For i = 1 To UBound(arr)
    
13.         Set c = Sheets("期初余额").Range("a:a").Find(no, , , , , 1)
    
14.         If k = 0 And Not c Is Nothing Then
    
15.             k = k + 1
    
16.             brr(k, 4) = "上年结转"             'brr数组第1行的第5列= “期初余额”
    
17.             brr(k, 8) = Sheets("期初余额").Range("c" & c.Row)          'brr数组第1行的第8列的“余额”
    
18.             If Range("I4") = "借" Then                                             '如果是借方科目，则如下：
    
19.                 brr(k, 7) = IIf(brr(k, 8) > 0, "借", IIf(brr(k, 8) < 0, "贷", ""))  '借或贷行赋值
    
20.             Else                                                                     '否则是贷方科目如下：
    
21.                 brr(k, 7) = IIf(brr(k, 8) > 0, "贷", IIf(brr(k, 8) < 0, "借", ""))  '借或贷行赋值
    
22.             End If
    
23.         End If
    
24.         If arr(i, 1) = no Then    'arr第1列的科目编码
    
25.             k = k + 1
    
26.             '===============主表区共6列赋值（中间有几列空列不赋值）
    
27.             On Error Resume Next
    
28.             If k > 1 Then                                                           '如果大于第一行
    
29.                 If arr(i, 5) <> brr(k - 1, 1) And brr(k - 1, 4) <> "上年结转" Then  '如果本行第1列的月份不等于上一行的月份或都不等于“上年结转”
    
30.                     按月汇总                                                        '插入本月合计和本年累计（从第1个月到最后一个月的上一月用此代码）
    
31.                 End If
    
32.             End If                    '上面是先判定本行是否属于下一月份，如果是先操作上面的月结，然后进入下面的按逐行顺序赋值
    
33.             brr(k, 1) = arr(i, 5)     '第1列月
    
34.             brr(k, 2) = arr(i, 6)     '第2列日
    
35.             brr(k, 3) = arr(i, 7)     '第3列凭证号
    
36.             brr(k, 4) = arr(i, 8)     '第4列摘要
    
37.             brr(k, 5) = arr(i, 9)     '第5到借方
    
38.             brr(k, 6) = arr(i, 10)    '第6到贷方
    
39. 
    
40.             '================余额栏计算
    
41.             r = IIf(brr(k - 1, 4) = "本年累计", 3, 1)                                   '计算余额列的上一行的行号，如果是新月份的开始行上一行余额是本行-3行，否则是本行政1行
    
42.             If Range("I4") = "借" Then                                             '如果是借方科目，则如下：
    
43.                 brr(k, 8) = Round(brr(k - r, 8) + brr(k, 5) - brr(k, 6), 2)           '余额行的数量计算
    
44.                 brr(k, 7) = IIf(brr(k, 8) > 0, "借", "贷")                            '借或贷行赋值
    
45.             Else                                                                      '否则是贷方科目如下：
    
46.                 brr(k, 8) = Round(brr(k - r, 8) + brr(k, 6) - brr(k, 5), 2)           '余额行的数量计算
    
47.                 brr(k, 7) = IIf(brr(k, 12) > 0, "贷", "借")                           '借或贷行赋值
    
48.             End If
    
49.             '================借贷方的本月合计（按月周期）本年累计（从头到尾）逐行累加
    
50.             mD额 = mD额 + brr(k, 5)       '上一行内存中的本月借方金额累计数和本行借方金额累加
    
51.             mC额 = mC额 + brr(k, 6)       '上一行内存中的本月贷方金额累计数和本行贷方数量累加
    
52.         End If
    
53.     Next i
    
54.     On Error Resume Next
    
55.     If k > 0 Then                      '如果不是空科目，即数组不为空
    
56.         If Len(brr(k, 1)) > 0 Then     '如果当前第1列是有月份的数据行（不是上年转入，本年合计、本年累计）
    
57.             k = k + 1                  '最后一月的下一行行号（本月合计行）
    
58.             按月汇总                   '插入最后一月的本月合计和本年累计
    
59.         End If
    
60.     End If
    
61.     Range("b8").Resize(k, 8) = brr                       'brr赋值
    
62.    ' Range("AR1") = 1                                       '页码切换为第1页
    
63.     Range("b8").Resize(k, 8).Borders.LineStyle = xlContinuous       '添加边框线
    
64.     For i = 9 To k + 8
    
65.         If Cells(i, 5) = "本月合计" Or Cells(i, 5) = "本年累计" Then
    
66.             Cells(i, 2).Resize(1, 8).Interior.ColorIndex = 20       '底色为浅蓝色
    
67.         End If
    
68.     Next
    
69.     Erase arr                                           ' 清空arr
    
70.     Erase brr                                           '清空brr
    
71.     k = 0                                               '清空行变量
    
72. '   yD数 = 0      '当月借方累计数量清0
    
73.     yD额 = 0      '当月借方累计金额清0
    
74. '   yC数 = 0      '当月借方累计数量清0
    
75.     yC额 = 0      '当月贷方累计金额清0
    
76. End Sub
    
77. 
    
78. Private Sub 按月汇总()
    
79.     brr(k, 4) = "本月合计"
    
80.     brr(k, 5) = mD额   '本月合计借方金额
    
81.     brr(k, 6) = mC额   '本月合计贷方金额
    
82.     yD额 = yD额 + mD额   '本年累计借方金额 = 上月余额（内存取出）+本月合计
    
83.     yC额 = yC额 + mC额   '本年累计贷方金额 = 上月余额（内存取出）+本月合计
    
84.     brr(k + 1, 4) = "本年累计"  '
    
85.     brr(k + 1, 5) = yD额   '借方金额本年累计赋值
    
86.     brr(k + 1, 6) = yC额   '贷方金额本年累计赋值
    
87.     mD额 = 0      '当月借方累计数清0
    
88.     mC额 = 0      '当月贷方累计数清0
    
89.     k = k + 2
    
90. End Sub
    

复制代码

hzruziniu

会计账查询.rar (89.74 KB, 下载次数: 29)

2020-7-9 11:47 上传

点击文件名下载附件

请看附件

hzruziniu

已发送的附件借贷方向有误，修改后重发。
会计账查询.rar (91.02 KB, 下载次数: 22)

2020-7-9 12:40 上传

点击文件名下载附件

说明：
1、科目名称单独设置一张工作表，最好把期初余额也在科目编码工作表中单独设置一列，这样不需要调出多个工作表取数。
2、科目编码用窗体查询，窗体列表下拉信息来源于科目编码工作表的A列（把编码与名称连接起来便于查询）用定义名称赋值给窗体查询。
3、懂财务的都知道明细账有借贷科目，方向相反，因此余额也应根据借贷来统计，所以借或贷是必填项。
具体代码如下：

1. Dim k&, arr, brr(1 To 1000, 1 To 12)
   
2. Dim mD数#, mD额#, mC数#, mC额#, yD数#, yD额#, yC数#, yC额#
   
3. 
   
4. Sub 明细账查询()
   
5.     Dim i&, no$, j%
   
6.     Range("b8:i1500").ClearContents                '清除数据区
   
7.     Range("b8:i1500").Borders.LineStyle = xlNone   '清除网格线
   
8.     Range("b8:i1500").Interior.Pattern = xlNone             '删除底色
   
9.     no = Range("d4")               '科目代码定义为no
   
10.     arr = Sheets("凭证明细表").Range("a2：j" & Sheets("凭证明细表").Range("a20000").End(3).Row) '.CurrentRegion  '分录源表装入数组arr
    
11.     k = 0
    
12.     For i = 1 To UBound(arr)
    
13.         Set c = Sheets("期初余额").Range("a:a").Find(no, , , , , 1)
    
14.         If k = 0 And Not c Is Nothing Then
    
15.             k = k + 1
    
16.             brr(k, 4) = "上年结转"             'brr数组第1行的第4列= “期初余额”
    
17.             brr(k, 8) = Sheets("期初余额").Range("c" & c.Row)          'brr数组第1行的第8列的“余额”
    
18.             If Range("I4") = "借" Then                                             '如果是借方科目，则如下：
    
19.                 brr(k, 7) = IIf(brr(k, 8) > 0, "借", IIf(brr(k, 8) < 0, "贷", ""))  '借或贷行赋值
    
20.             Else                                                                     '否则是贷方科目如下：
    
21.                 brr(k, 7) = IIf(brr(k, 8) > 0, "贷", IIf(brr(k, 8) < 0, "借", ""))  '借或贷行赋值
    
22.             End If
    
23.         End If
    
24.         If arr(i, 1) = no Then    'arr第1列的科目编码
    
25.             k = k + 1
    
26.             '===============主表区共6列赋值（中间有几列空列不赋值）
    
27.             On Error Resume Next
    
28.             If k > 1 Then                                                           '如果大于第一行
    
29.                 If arr(i, 5) <> brr(k - 1, 1) And brr(k - 1, 4) <> "上年结转" Then  '如果本行第1列的月份不等于上一行的月份或都不等于“上年结转”
    
30.                     按月汇总                                                        '插入本月合计和本年累计（从第1个月到最后一个月的上一月用此代码）
    
31.                 End If
    
32.             End If                    '上面是先判定本行是否属于下一月份，如果是先操作上面的月结，然后进入下面的按逐行顺序赋值
    
33.             brr(k, 1) = arr(i, 5)     '第1列月
    
34.             brr(k, 2) = arr(i, 6)     '第2列日
    
35.             brr(k, 3) = arr(i, 7)     '第3列凭证号
    
36.             brr(k, 4) = arr(i, 8)     '第4列摘要
    
37.             brr(k, 5) = arr(i, 9)     '第5到借方
    
38.             brr(k, 6) = arr(i, 10)    '第6到贷方
    
39. 
    
40.             '================余额栏计算
    
41.             r = IIf(brr(k - 1, 4) = "本年累计", 3, 1)                                   '计算余额列的上一行的行号，如果是新月份的开始行上一行余额是本行-3行，否则是本行政1行
    
42.             If Range("I4") = "借" Then                                             '如果是借方科目，则如下：
    
43.                 brr(k, 8) = Round(brr(k - r, 8) + brr(k, 5) - brr(k, 6), 2)           '余额行的数量计算
    
44.                 brr(k, 7) = IIf(brr(k, 8) > 0, "借", "贷")                            '借或贷行赋值
    
45.             Else                                                                      '否则是贷方科目如下：
    
46.                 brr(k, 8) = Round(brr(k - r, 8) + brr(k, 6) - brr(k, 5), 2)           '余额行的数量计算
    
47.                 brr(k, 7) = IIf(brr(k, 8) > 0, "贷", "借")                           '借或贷行赋值
    
48.             End If
    
49.             '================借贷方的本月合计（按月周期）本年累计（从头到尾）逐行累加
    
50.             mD额 = mD额 + brr(k, 5)       '上一行内存中的本月借方金额累计数和本行借方金额累加
    
51.             mC额 = mC额 + brr(k, 6)       '上一行内存中的本月贷方金额累计数和本行贷方数量累加
    
52.         End If
    
53.     Next i
    
54.     On Error Resume Next
    
55.     If k > 0 Then                      '如果不是空科目，即数组不为空
    
56.         If Len(brr(k, 1)) > 0 Then     '如果当前第1列是有月份的数据行（不是上年转入，本年合计、本年累计）
    
57.             k = k + 1                  '最后一月的下一行行号（本月合计行）
    
58.             按月汇总                   '插入最后一月的本月合计和本年累计
    
59.         End If
    
60.     End If
    
61.     Range("b8").Resize(k, 8) = brr                       'brr赋值
    
62.    ' Range("AR1") = 1                                       '页码切换为第1页
    
63.     Range("b8").Resize(k, 8).Borders.LineStyle = xlContinuous       '添加边框线
    
64.     For i = 9 To k + 8
    
65.         If Cells(i, 5) = "本月合计" Or Cells(i, 5) = "本年累计" Then
    
66.             Cells(i, 2).Resize(1, 8).Interior.ColorIndex = 20       '底色为浅蓝色
    
67.         End If
    
68.     Next
    
69.     Erase arr                                           ' 清空arr
    
70.     Erase brr                                           '清空brr
    
71.     k = 0                                               '清空行变量
    
72. '   yD数 = 0      '当月借方累计数量清0
    
73.     yD额 = 0      '当月借方累计金额清0
    
74. '   yC数 = 0      '当月借方累计数量清0
    
75.     yC额 = 0      '当月贷方累计金额清0
    
76. End Sub
    
77. 
    
78. Private Sub 按月汇总()
    
79.     brr(k, 4) = "本月合计"
    
80.     brr(k, 5) = mD额   '本月合计借方金额
    
81.     brr(k, 6) = mC额   '本月合计贷方金额
    
82.     yD额 = yD额 + mD额   '本年累计借方金额 = 上月余额（内存取出）+本月合计
    
83.     yC额 = yC额 + mC额   '本年累计贷方金额 = 上月余额（内存取出）+本月合计
    
84.     brr(k + 1, 4) = "本年累计"  '
    
85.     brr(k + 1, 5) = yD额   '借方金额本年累计赋值
    
86.     brr(k + 1, 6) = yC额   '贷方金额本年累计赋值
    
87.     mD额 = 0      '当月借方累计数清0
    
88.     mC额 = 0      '当月贷方累计数清0
    
89.     k = k + 2
    
90. End Sub
    

复制代码

hzruziniu

会计账查询.rar (91.02 KB, 下载次数: 45)

2020-7-9 13:28 上传

点击文件名下载附件

1. Dim k&, arr, brr(1 To 1000, 1 To 12)
   
2. Dim mD数#, mD额#, mC数#, mC额#, yD数#, yD额#, yC数#, yC额#
   
3. 
   
4. Sub 明细账查询()
   
5.     Dim i&, no$, j%
   
6.     Range("b8:i1500").ClearContents                '清除数据区
   
7.     Range("b8:i1500").Borders.LineStyle = xlNone   '清除网格线
   
8.     Range("b8:i1500").Interior.Pattern = xlNone             '删除底色
   
9.     no = Range("d4")               '科目代码定义为no
   
10.     arr = Sheets("凭证明细表").Range("a2：j" & Sheets("凭证明细表").Range("a20000").End(3).Row) '.CurrentRegion  '分录源表装入数组arr
    
11.     k = 0
    
12.     For i = 1 To UBound(arr)
    
13.         Set c = Sheets("期初余额").Range("a:a").Find(no, , , , , 1)
    
14.         If k = 0 And Not c Is Nothing Then
    
15.             k = k + 1
    
16.             brr(k, 4) = "上年结转"             'brr数组第1行的第4列= “期初余额”
    
17.             brr(k, 8) = Sheets("期初余额").Range("c" & c.Row)          'brr数组第1行的第8列的“余额”
    
18.             If Range("I4") = "借" Then                                             '如果是借方科目，则如下：
    
19.                 brr(k, 7) = IIf(brr(k, 8) > 0, "借", IIf(brr(k, 8) < 0, "贷", ""))  '借或贷行赋值
    
20.             Else                                                                     '否则是贷方科目如下：
    
21.                 brr(k, 7) = IIf(brr(k, 8) > 0, "贷", IIf(brr(k, 8) < 0, "借", ""))  '借或贷行赋值
    
22.             End If
    
23.         End If
    
24.         If arr(i, 1) = no Then    'arr第1列的科目编码
    
25.             k = k + 1
    
26.             '===============主表区共6列赋值（中间有几列空列不赋值）
    
27.             On Error Resume Next
    
28.             If k > 1 Then                                                           '如果大于第一行
    
29.                 If arr(i, 5) <> brr(k - 1, 1) And brr(k - 1, 4) <> "上年结转" Then  '如果本行第1列的月份不等于上一行的月份或都不等于“上年结转”
    
30.                     按月汇总                                                        '插入本月合计和本年累计（从第1个月到最后一个月的上一月用此代码）
    
31.                 End If
    
32.             End If                    '上面是先判定本行是否属于下一月份，如果是先操作上面的月结，然后进入下面的按逐行顺序赋值
    
33.             brr(k, 1) = arr(i, 5)     '第1列月
    
34.             brr(k, 2) = arr(i, 6)     '第2列日
    
35.             brr(k, 3) = arr(i, 7)     '第3列凭证号
    
36.             brr(k, 4) = arr(i, 8)     '第4列摘要
    
37.             brr(k, 5) = arr(i, 9)     '第5到借方
    
38.             brr(k, 6) = arr(i, 10)    '第6到贷方
    
39. 
    
40.             '================余额栏计算
    
41.             r = IIf(brr(k - 1, 4) = "本年累计", 3, 1)                                   '计算余额列的上一行的行号，如果是新月份的开始行上一行余额是本行-3行，否则是本行政1行
    
42.             If Range("I4") = "借" Then                                             '如果是借方科目，则如下：
    
43.                 brr(k, 8) = Round(brr(k - r, 8) + brr(k, 5) - brr(k, 6), 2)           '余额行的数量计算
    
44.                 brr(k, 7) = IIf(brr(k, 8) > 0, "借", "贷")                            '借或贷行赋值
    
45.             Else                                                                      '否则是贷方科目如下：
    
46.                 brr(k, 8) = Round(brr(k - r, 8) + brr(k, 6) - brr(k, 5), 2)           '余额行的数量计算
    
47.                 brr(k, 7) = IIf(brr(k, 8) > 0, "贷", "借")                           '借或贷行赋值
    
48.             End If
    
49.             '================借贷方的本月合计（按月周期）本年累计（从头到尾）逐行累加
    
50.             mD额 = mD额 + brr(k, 5)       '上一行内存中的本月借方金额累计数和本行借方金额累加
    
51.             mC额 = mC额 + brr(k, 6)       '上一行内存中的本月贷方金额累计数和本行贷方数量累加
    
52.         End If
    
53.     Next i
    
54.     On Error Resume Next
    
55.     If k > 0 Then                      '如果不是空科目，即数组不为空
    
56.         If Len(brr(k, 1)) > 0 Then     '如果当前第1列是有月份的数据行（不是上年转入，本年合计、本年累计）
    
57.             k = k + 1                  '最后一月的下一行行号（本月合计行）
    
58.             按月汇总                   '插入最后一月的本月合计和本年累计
    
59.         End If
    
60.     End If
    
61.     Range("b8").Resize(k, 8) = brr                       'brr赋值
    
62.    ' Range("AR1") = 1                                       '页码切换为第1页
    
63.     Range("b8").Resize(k, 8).Borders.LineStyle = xlContinuous       '添加边框线
    
64.     For i = 9 To k + 8
    
65.         If Cells(i, 5) = "本月合计" Or Cells(i, 5) = "本年累计" Then
    
66.             Cells(i, 2).Resize(1, 8).Interior.ColorIndex = 20       '底色为浅蓝色
    
67.         End If
    
68.     Next
    
69.     Erase arr                                           ' 清空arr
    
70.     Erase brr                                           '清空brr
    
71.     k = 0                                               '清空行变量
    
72. '   yD数 = 0      '当月借方累计数量清0
    
73.     yD额 = 0      '当月借方累计金额清0
    
74. '   yC数 = 0      '当月借方累计数量清0
    
75.     yC额 = 0      '当月贷方累计金额清0
    
76. End Sub
    
77. 
    
78. Private Sub 按月汇总()
    
79.     brr(k, 4) = "本月合计"
    
80.     brr(k, 5) = mD额   '本月合计借方金额
    
81.     brr(k, 6) = mC额   '本月合计贷方金额
    
82.     yD额 = yD额 + mD额   '本年累计借方金额 = 上月余额（内存取出）+本月合计
    
83.     yC额 = yC额 + mC额   '本年累计贷方金额 = 上月余额（内存取出）+本月合计
    
84.     brr(k + 1, 4) = "本年累计"  '
    
85.     brr(k + 1, 5) = yD额   '借方金额本年累计赋值
    
86.     brr(k + 1, 6) = yC额   '贷方金额本年累计赋值
    
87.     mD额 = 0      '当月借方累计数清0
    
88.     mC额 = 0      '当月贷方累计数清0
    
89.     k = k + 2
    
90. End Sub
    

复制代码

zgjijinbao

chxw68 发表于 2020-6-30 16:04
修改好了。

老师！我的余额是这样显示的，能不能显示为0

zgjijinbao

这样的，先谢谢老师了！

高度保密

hzruziniu 发表于 2020-7-9 12:41
已发送的附件借贷方向有误，修改后重发。

说明：

不懂财务，对借贷一直是迷迷糊糊的，看附件的明细，银行存款有借有贷，但是结果中没有区分出来，不知道是不是我理解错误

chxw68

zgjijinbao 发表于 2020-7-9 16:12
这样的，先谢谢老师了！

把你的文件发上来。

zgjijinbao

chxw68 发表于 2020-7-9 19:05
把你的文件发上来。

谢谢了！给你找麻烦了

zgjijinbao

zgjijinbao 发表于 2020-7-9 20:17
谢谢了！给你找麻烦了

能不能摘要栏显示上年结存