研发费用台账明细表自动生成模板。

hyz00001

按照项目编号自动生成每个项目单独的研发明细账.
适配新政策,2021版研发台账明细表可以按照基础数据自动生成.
希望朋友们喜欢.

代码如下,未使用类模块.

1. Sub 研发辅助明细账()
   
2.     Application.ScreenUpdating = False
   
3.     Set wbk = ActiveWorkbook
   
4.     Set sht = wbk.Sheets("数据源")
   
5.     Set nht = wbk.Sheets("研发支出辅助账")
   
6.     Set 项目 = CreateObject("Scripting.Dictionary")
   
7.     Dim 子研发明细(1 To 65536, 1 To 30)
   
8.     arr = sht.[a1].CurrentRegion
   
9.     For y = 1 To UBound(arr, 2)
   
10.         If InStr(arr(1, y), "项目编号") Then 项目号no = y
    
11.         If InStr(arr(1, y), "项目名称") Then 项目名no = y
    
12.         If arr(1, y) = "日期" Then 日期no = y
    
13.         If InStr(arr(1, y), "凭证号") Then 凭证号no = y
    
14.         If InStr(arr(1, y), "摘要") Then 摘要no = y
    
15.         If InStr(arr(1, y), "借方") Then 金额no = y
    
16.         If InStr(arr(1, y), "归类") Then 归类no = y
    
17.     Next y
    
18.     For x = 2 To UBound(arr)
    
19.         If 项目.exists(arr(x, 项目号no)) = False Then
    
20.             so = so + 1
    
21.             项目(arr(x, 项目号no)) = arr(x, 项目名no)
    
22.         End If
    
23.     Next x
    
24.     For Each 项目n In 项目.keys
    
25.         Debug.Print 项目n
    
26.         For x = 2 To UBound(arr)
    
27.             If arr(x, 项目号no) = 项目n And arr(x, 金额no) <> 0 Then
    
28.                 sw = sw + 1
    
29.                 子研发明细(sw, 1) = arr(x, 日期no)
    
30.                 子研发明细(sw, 2) = "记"
    
31.                 子研发明细(sw, 3) = arr(x, 凭证号no)
    
32.                 子研发明细(sw, 4) = arr(x, 摘要no)
    
33.                 子研发明细(sw, 5) = arr(x, 金额no)
    
34.                 子研发明细(sw, 6) = 子研发明细(sw, 5)
    
35.                 Select Case arr(x, 归类no)
    
36.                     Case "人员人工费用"
    
37.                         子研发明细(sw, 7) = arr(x, 金额no)
    
38.                     Case "直接投入费用"
    
39.                         子研发明细(sw, 8) = arr(x, 金额no)
    
40.                     Case "折旧费用"
    
41.                         子研发明细(sw, 9) = arr(x, 金额no)
    
42.                     Case "无形资产摊销"
    
43.                         子研发明细(sw, 10) = arr(x, 金额no)
    
44.                     Case "新产品 设计费等"
    
45.                         子研发明细(sw, 11) = arr(x, 金额no)
    
46.                     Case "其他相关费用合计"
    
47.                         子研发明细(sw, 12) = arr(x, 金额no)
    
48.                     Case "委托境外机构进行研发活动所发生的费用"
    
49.                         子研发明细(sw, 14) = arr(x, 金额no)
    
50.                 End Select
    
51.             End If
    
52.         Next x
    
53.         nht.Copy after:=Sheets(Sheets.Count)
    
54.         ActiveSheet.Name = 项目n
    
55.         ActiveSheet.[a3] = "项目编号：" & 项目n
    
56.         ActiveSheet.[f3] = "项目名称：" & 项目(项目n)
    
57.         If sw > 7 Then [a8].Resize(sw - 6, 1).EntireRow.Insert
    
58.         If sw > 0 Then [a7].Resize(sw, 14) = 子研发明细
    
59.         
    
60.         Erase 子研发明细
    
61.         sw = 0
    
62.         '[a7].Resize(sw, 14).EntireRow.RowHeight = 18
    
63.     Next 项目n
    
64. Application.ScreenUpdating = True
    
65. End Sub
    

复制代码

hyz00001

好的分享,希望对大家有帮助,而不是垃圾一样堆放在某个角落.

blackttea1

谢谢分享！

日月星梭

谢谢楼主分享，正是我需要的

kreal

你好，你设计的这个表真好。只是第54行运行错误，代码1004，此名称已被使用，怎么处理，能帮忙测试一下吗？谢谢

jjmysjg

加个代码：运行时删除原来生成的表。

kreal

jjmysjg 发表于 2024-5-17 09:47
加个代码：运行时删除原来生成的表。

VBA小白，麻烦写一下

ylf969

谢谢分享！

jjmysjg

kreal 发表于 2024-5-17 10:07
VBA小白，麻烦写一下

Sub 批量删除t()

gaolzhen

谢谢分享，欣赏了。。。