如何将记账凭证库中的数据自动登记到“现金日记账”簿中？

李文宇

如何将图一中的数据自动登记到图二中，结果如图三。

zpy2

可以试试把凭证库 a1:q54 复制粘贴到 下面这个在线 现金日记账 的生成工具。

李文宇

zpy2 发表于 2018-2-27 20:01
可以试试把凭证库 a1:q54 复制粘贴到 下面这个在线 现金日记账 的生成工具。

谢谢您。我试一试。

李文宇

zpy2 发表于 2018-2-27 20:01
可以试试把凭证库 a1:q54 复制粘贴到 下面这个在线 现金日记账 的生成工具。

您还有更好的的办法吗？能不能帮我录制和“登记现金明细”的宏？谢谢

xd3210

不懂财会知识，帮助顶，继续关注

zpy2

李文宇 发表于 2018-3-1 09:00
您还有更好的的办法吗？能不能帮我录制和“登记现金明细”的宏？谢谢

这个用宏可能比较麻烦，你可以参考下数组字典方面的代码或者其他财务方面的，我是用数据库做的。

一指禅62

1. Sub 编制现金账()
   
2.     Dim arr, i&, a(), n&, Rng As Range, M
   
3.     Rem 清除旧有现金账数据，填写上年结转数据
   
4.     Set Rng = Sheet1.Range("B:B").Find("库存现金", lookat:=xlWhole)
   
5.     If Not Rng Is Nothing Then M = Rng.Offset(0, 3).Value
   
6.     Sheet15.Range("A5:K65536").ClearContents
   
7.     Sheet15.Range("F5") = "上年结转"
   
8.     Sheet15.Range("K5") = M
   
9.     Rem 编制当期现金日记账
   
10.     arr = Sheets("凭证库").Range("A1").CurrentRegion
    
11.     For i = 2 To UBound(arr)
    
12.         If arr(i, 5) = "库存现金" Then
    
13.             n = n + 1: ReDim Preserve a(1 To 11, 1 To n)
    
14.             M = M + arr(i, 7)
    
15.             a(1, n) = arr(i, 13) '月
    
16.             a(2, n) = arr(i, 14) '日
    
17.             a(4, n) = arr(i, 15) '号
    
18.             a(5, n) = arr(i, 9) '对方科目
    
19.             a(6, n) = arr(i, 3) '摘要
    
20.             a(7, n) = "现收" '类别
    
21.             a(8, n) = arr(i, 7) '借方
    
22.             a(11, n) = M '余额
    
23.         ElseIf arr(i, 9) = "库存现金" Then
    
24.             n = n + 1: ReDim Preserve a(1 To 11, 1 To n)
    
25.             M = M - arr(i, 11)
    
26.             a(1, n) = arr(i, 13) '月
    
27.             a(2, n) = arr(i, 14) '日
    
28.             a(4, n) = arr(i, 15) '号
    
29.             a(5, n) = arr(i, 5) '对方科目
    
30.             a(6, n) = arr(i, 3) '摘要
    
31.             a(7, n) = "现付" '类别
    
32.             a(9, n) = arr(i, 11) '贷方
    
33.             a(11, n) = M '余额
    
34.         End If
    
35.     Next
    
36.     If n > 0 Then Sheet15.Range("A6").Resize(n, UBound(a)) = WorksheetFunction.Transpose(a)
    
37. End Sub

复制代码

一指禅62

编制现金账.rar (153.2 KB, 下载次数: 64)

2018-3-1 11:06 上传

点击文件名下载附件

chxw68

1. Sub test()
   
2.   Dim r%, i%, m%
   
3.   Dim arr, brr(1 To 10000, 1 To 11)
   
4.   m = 1
   
5.   With Worksheets("科目代码表")
   
6.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
7.     arr = .Range("a2:e" & r)
   
8.     For i = 1 To UBound(arr)
   
9.       If arr(i, 2) = "库存现金" Then
   
10.         Exit For
    
11.       End If
    
12.     Next
    
13.     If i <= UBound(arr) Then
    
14.       brr(m, 6) = "上年结转"
    
15.       brr(m, 11) = arr(i, 5)
    
16.     End If
    
17.   End With
    
18.    
    
19.   With Worksheets("凭证库")
    
20.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
21.     arr = .Range("a2:q" & r)
    
22.     For i = 1 To UBound(arr)
    
23.       If arr(i, 5) = "库存现金" Or arr(i, 9) = "库存现金" Then
    
24.         m = m + 1
    
25.         brr(m, 1) = arr(i, 13)
    
26.         brr(m, 2) = arr(i, 14)
    
27.         brr(m, 4) = arr(i, 15)
    
28.         brr(m, 6) = arr(i, 3)
    
29.         If arr(i, 5) = "库存现金" Then
    
30.           brr(m, 5) = arr(i, 9)
    
31.           brr(m, 8) = arr(i, 7)
    
32.           brr(m, 11) = brr(m - 1, 11) + brr(m, 8)
    
33.         Else
    
34.           brr(m, 5) = arr(i, 5)
    
35.           brr(m, 9) = arr(i, 7)
    
36.           brr(m, 11) = brr(m - 1, 11) - brr(m, 9)
    
37.         End If
    
38.       End If
    
39.     Next
    
40.   End With
    
41.   With Worksheets("现金日记账")
    
42.     .Range("a5:k" & .Rows.Count).ClearContents
    
43.     .Range("a5").Resize(m, 11) = brr
    
44.   End With
    
45. End Sub
    

复制代码

chxw68

详见附件。