分享一个专门给审计准备的固定资产平衡表

hyz00001

在对固定资产审计时需要一份与TB账目相符的固定资产清单表，并且显示出全部的借贷方向等内容。
以下代码就是专门用来搞这个的。
你需要提取期初资产清单、期末资产清单、固定资产明细账（这些都可以在金蝶K/3系统中的固定资产模块找到。）
以下代码就能帮你搞定。
欢迎大师指点，谢谢！

1. Sub 固定资产模板()
   
2. Application.ScreenUpdating = False
   
3. Dim ar, cr, dr
   
4. Dim a, b, c, d, x, y, r, rx, ry, n, item
   
5. Dim kw As New 数组
   
6. Set bg原值 = CreateObject("Scripting.Dictionary")   '创建一个字典对象
   
7. Set bg折旧 = CreateObject("Scripting.Dictionary")   '创建一个字典对象
   
8. Set ed原值 = CreateObject("Scripting.Dictionary")   '创建一个字典对象
   
9. Set ed折旧 = CreateObject("Scripting.Dictionary")   '创建一个字典对象
   
10. Set dr原值 = CreateObject("Scripting.Dictionary")   '创建一个字典对象
    
11. Set cr原值 = CreateObject("Scripting.Dictionary")   '创建一个字典对象
    
12. Set dr折旧 = CreateObject("Scripting.Dictionary")   '创建一个字典对象
    
13. Set cr折旧 = CreateObject("Scripting.Dictionary")   '创建一个字典对象
    
14. Set d = CreateObject("Scripting.Dictionary")  '创建一个字典对象
    
15. Set n = CreateObject("Scripting.Dictionary")   '创建一个字典对象
    
16. Set s = CreateObject("Scripting.Dictionary")   '创建一个字典对象
    
17. '期初清单
    
18. Cells.Replace Chr(13), "": Cells.Replace Chr(10), ""
    
19. Sheets("期初清单").Activate: ar = [a1].CurrentRegion
    
20. 资产编码 = kw.所在列(ar, "资产编码", 1)
    
21. 期初原值 = kw.所在列(ar, "原值本币", 1)
    
22. 期初折旧 = kw.所在列(ar, "累计折旧", 1)
    
23. For x = 1 To UBound(ar)
    
24. If ar(x, 资产编码) <> "总计" And ar(x, 资产编码) <> "" Then
    
25.     bg原值("'" & ar(x, 资产编码)) = ar(x, 期初原值)
    
26.     bg折旧("'" & ar(x, 资产编码)) = ar(x, 期初折旧)
    
27.     If d.exists("'" & ar(x, 资产编码)) = False Then d("'" & ar(x, 资产编码)) = "1"
    
28. End If
    
29. Next x
    
30. '期末清单
    
31. Cells.Replace Chr(13), "": Cells.Replace Chr(10), ""
    
32. Sheets("期末清单").Activate: ar = [a1].CurrentRegion
    
33. 资产编码 = kw.所在列(ar, "资产编码", 1)
    
34. 期末原值 = kw.所在列(ar, "原值本币", 1)
    
35. 期末折旧 = kw.所在列(ar, "累计折旧", 1)
    
36. For x = 1 To UBound(ar)
    
37. If ar(x, 资产编码) <> "总计" And ar(x, 资产编码) <> "" Then
    
38.     ed原值("'" & ar(x, 资产编码)) = ar(x, 期末原值)
    
39.     ed折旧("'" & ar(x, 资产编码)) = ar(x, 期末折旧)
    
40.     If d.exists("'" & ar(x, 资产编码)) = False Then d("'" & ar(x, 资产编码)) = "1"
    
41. End If
    
42. Next x
    
43. '固定资产明细账中提取 dr原值 ,cr原值,dr折旧
    
44. Cells.Replace Chr(13), "": Cells.Replace Chr(10), ""
    
45. Sheets("明细账").Activate: ar = [a1].CurrentRegion
    
46. 资产编码 = kw.所在列(ar, "资产编码", 1)
    
47. 原值借方 = kw.所在列(ar, "原值(综合本位币):借方金额", 1)
    
48. 原值贷方 = kw.所在列(ar, "原值(综合本位币):贷方金额", 1)
    
49. 折旧借方 = kw.所在列(ar, "累计折旧(综合本位币):借方金额", 1)
    
50. For x = 1 To UBound(ar)
    
51. If ar(x, 资产编码) <> "总计" And ar(x, 资产编码) <> "" Then
    
52.     dr原值("'" & ar(x, 资产编码)) = ar(x, 原值借方) + dr原值("'" & ar(x, 资产编码))
    
53.     cr原值("'" & ar(x, 资产编码)) = ar(x, 原值贷方) + cr原值("'" & ar(x, 资产编码))
    
54.     dr折旧("'" & ar(x, 资产编码)) = ar(x, 折旧借方) + dr折旧("'" & ar(x, 资产编码))
    
55.     If d.exists("'" & ar(x, 资产编码)) = False Then d("'" & ar(x, 资产编码)) = "1"
    
56. End If
    
57. Next x
    
58. 
    
59. 
    
60. 
    
61. 
    
62. Sheets("总表").Activate: Sheets("总表").Cells.ClearContents
    
63. [a1].Resize(d.Count, 1) = WorksheetFunction.Transpose(d.keys)
    
64. br = Range(Cells(1, 1), Cells(d.Count, 15))
    
65. For x = 2 To UBound(br)
    
66.    
    
67.     br(x, 2) = bg原值("'" & br(x, 1))
    
68.     br(x, 3) = bg折旧("'" & br(x, 1))
    
69.     br(x, 4) = dr原值("'" & br(x, 1))
    
70.     br(x, 5) = cr原值("'" & br(x, 1))
    
71.     br(x, 6) = dr折旧("'" & br(x, 1))
    
72.     br(x, 7) = dr折旧("'" & br(x, 1)) + ed折旧("'" & br(x, 1)) - bg折旧("'" & br(x, 1))
    
73.     br(x, 8) = ed原值("'" & br(x, 1))
    
74.     br(x, 9) = ed折旧("'" & br(x, 1))
    
75.    
    
76. Next x
    
77. '    br(1, 7) = "折旧贷方"
    
78.     [b1].Resize(UBound(br), 9) = br
    
79.     [a1].Resize(1, 10) = Split("资产编码,资产编码,bg原值,bg折旧,dr原值,cr原值,dr折旧,cr折旧,ed原值,ed折旧", ",")
    
80.     c = Cells(Rows.Count, 1).End(xlUp).Row
    
81.     Range(Cells(c + 2, 3), Cells(c + 2, 10)).FormulaR1C1 = "=sum(r2c:r[-1]c)":    Cells(c + 2, 2) = "total"
    
82. 'Stop
    
83. [k1].Resize(1, 8) = Split("资产名称,类别,入账日期,使用部门,存放地点,使用寿命,剩余寿命,管理者编", ",")
    
84. rx = Cells(Rows.Count, 1).End(xlUp).Row
    
85. ry = Cells(1, Columns.Count).End(xlToLeft).Column
    
86. Range(Cells(2, "k"), Cells(rx, ry)).FormulaR1C1 = "=IFERROR(IFERROR(VLOOKUP(RC1,期末清单!C1:C32,MATCH(R1C,期末清单!R1,0),0),VLOOKUP(RC1,期初清单!C1:C32,MATCH(R1C,期初清单!R1,0),0)),"""")"
    
87. ActiveWorkbook.Protect Structure:=True, Windows:=False
    
88. 'ActiveWorkbook.Unprotect
    
89. End Sub
    
90. 
    

复制代码

woyaofacai

最好能有实例文件，不知道这个代码有没有限定单元格条件的

hyz00001

因为涉及到公司数据，不能拿来演示，若有感兴趣的朋友，可以尝试上传资料，我们一起研究。
只需要从金蝶K/3系统中引出三张表即可。

hyz00001

已经搞定，使用ADO技术来实现。代码如下：

1.     Set conn = CreateObject("ADODB.Connection")   '
   
2.     Set rst = CreateObject("ADODB.Recordset")  '
   
3.     conn.Open "dsn=excel files;dbq=" & ThisWorkbook.FullName
   
4.     bm1 = "select 资产编码 from [期初清单$] union all select 资产编码 from [期末清单$] union all select 资产编码 from [明细账$]"
   
5.     bm = "select distinct 资产编码 from (" & bm1 & ")"
   
6.     s1 = "select 资产编码,原值本币 as bg原值,累计折旧 As bg折旧 from [期初清单$]"
   
7.     s2 = "select 资产编码,原值本币 as bg原值,累计折旧 As bg折旧 from [期末清单$]"
   
8.     s3 = "select 资产编码,[原值(综合本位币):借方金额] as dr原值,[原值(综合本位币):贷方金额] As cr折旧,[累计折旧(综合本位币):借方金额] as dr折旧 from [明细账$]"
   
9.    
   
10.     s4 = "select t1.资产编码 as 资产编码,* from (" & bm & ") t1 left join (" & s1 & ") t2 on t1.资产编码=t2.资产编码"
    
11.     s5 = "select t3.资产编码 as 资产编码,* from (" & s4 & ") t3 left join (" & s2 & ") t4 on t3.资产编码=t4.资产编码"
    
12.     s6 = "select * from (" & s5 & ") t5 left join (" & s3 & ") t6 on t5.资产编码=t6.资产编码 where not(isnull(t5.资产编码))"
    
13.     s7 = "select t1.资产编码,bg原值,bg折旧,dr原值,cr原值,dr折旧,cr折旧,ed原值,ed折旧 from (" & s6 & ")"
    
14.     s = "select * from (select t1.资产编码 from (" & bm & ") t1 left join (" & s1 & ") t2 on t1.资产编码=t2.资产编码) t1 left join (" & s1 & ") t2 on t1.资产编码=t2.资产编码"
    
15.     s = "select * from (" & bm & ") t1,(" & s1 & ") t2,(" & s2 & ") t3 where t1.资产编码=t2.资产编码 and t1.资产编码=t3.资产编码"
    
16.    
    
17.     Set rst = conn.Execute(s6)
    
18.     Sheets("表").[a2].CopyFromRecordset rst
    
19.     's = "select t2.资产编码, t1.bg原值, t1.bg折旧, t2.ed原值, t2.ed折旧 from (select 资产编码, 原值本币 as bg原值, 累计折旧 as bg折旧 from [期初清单$] )as t1 full join (select 资产编码, 原值本币 as ed原值, 累计折旧 as ed折旧 from [期末清单$] )as t2 on t1.资产编码 = t2.资产编码"
    
20.     For i = 0 To rst.Fields.Count - 1
    
21.         Cells(1, i + 1) = rst.Fields(i).Name
    
22.     Next
    
23. end sub
    

复制代码