用数据字典？

cxd1001

要求：
辅助账从研发明细账取符合条件的记录，条件是两表项目编号相同、明细ID相等，相应数据填入辅助账的相应栏次

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   Set d1 = CreateObject("scripting.dictionary")
   
7.   n = 6
   
8.   For Each x In Array("1.1", "1.2", "1.3", "2.1", "2.2", "2.3")
   
9.     n = n + 1
   
10.     d1(x) = n
    
11.   Next
    
12.   With Worksheets("研发明细账")
    
13.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
14.     arr = .Range("a2:j" & r)
    
15.     For i = 1 To UBound(arr)
    
16.       If Not d.exists(arr(i, 7)) Then
    
17.         Set d(arr(i, 7)) = CreateObject("scripting.dictionary")
    
18.       End If
    
19.       If Not d(arr(i, 7)).exists(arr(i, 1)) Then
    
20.         ReDim brr(1 To 12)
    
21.         For j = 1 To 4
    
22.           brr(j) = arr(i, j)
    
23.         Next
    
24.       Else
    
25.         brr = d(arr(i, 7))(arr(i, 1))
    
26.       End If
    
27.       brr(5) = brr(5) + arr(i, 5)
    
28.       brr(6) = brr(6) + arr(i, 6)
    
29.       If d1.exists(CStr(arr(i, 9))) Then
    
30.         n = d1(CStr(arr(i, 9)))
    
31.         brr(n) = brr(n) + arr(i, 5)
    
32.       End If
    
33.       d(arr(i, 7))(arr(i, 1)) = brr
    
34.     Next
    
35.   End With
    
36.   With Worksheets("辅助账")
    
37.     .Cells.Clear
    
38.     For Each aa In d.keys
    
39.       r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
40.       If r > 1 Then
    
41.         r = r + 2
    
42.       End If
    
43.       .Cells(r, 1) = "项目编号"
    
44.       .Cells(r, 2) = aa
    
45.       .Cells(r + 1, 7).Resize(1, 6) = Array("工资薪金", "五险一金", "外聘研发人员的劳务费用", "材料", "燃料", "动力费用")
    
46.       .Cells(r + 2, 7).Resize(1, 6) = Array("1.1", "1.2", "1.3", "2.1", "2.2", "2.3")
    
47.       .Cells(r + 2, 1).Resize(1, 6) = Array("日期", "类别", "凭证号", "摘要", "借方金额", "贷方金额")
    
48.       r = r + 2
    
49.       For Each bb In d(aa).keys
    
50.         r = r + 1
    
51.         brr = d(aa)(bb)
    
52.         .Cells(r, 1).Resize(1, UBound(brr)) = brr
    
53.       Next
    
54.     Next
    
55.   End With
    
56. End Sub
    

复制代码

chxw68

把题意搞得不是太明白，凭感觉写了一个不一定对。

cxd1001

chxw68 发表于 2017-3-8 10:09
把题意搞得不是太明白，凭感觉写了一个不一定对。

厉害！大致是这个意思
但是表头是固定，官方要求的固定格式，我重新上传的附件，见SHEET1、sheet2的格式，要求SHEET1、sheet2表体部分涂颜色的单元格数据从“研发明细账”提取数据

cxd1001

厉害！大致意思是这样
但是，表头要固定眀复杂，只需要填表体内容即可，已重新制作附件，
具体要求是：从“研发明细账”提取数据 分别填入 sheet1、sheets2表表体涂颜色部分的单元格

chxw68

cxd1001 发表于 2017-3-8 15:25
厉害！大致意思是这样
但是，表头要固定眀复杂，只需要填表体内容即可，已重新制作附件，
具体要求是：从 ...

总共只有这两个项目，还是说有很多项目？

cxd1001

chxw68 发表于 2017-3-8 16:23
总共只有这两个项目，还是说有很多项目？

最多可能会有20-30来个项目

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr, lk()
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   Set d1 = CreateObject("scripting.dictionary")
   
7.   Set d2 = CreateObject("scripting.dictionary")
   
8.   With Worksheets("模板")
   
9.     c = .Cells(7, .Columns.Count).End(xlToLeft).Column
   
10.     arr = .Range("a7").Resize(1, c)
    
11.     ReDim lk(1 To c)
    
12.     For j = 10 To UBound(arr, 2)
    
13.       d1(CStr(arr(1, j))) = j
    
14.     Next
    
15.     For j = 1 To c
    
16.       lk(j) = .Columns(j).ColumnWidth
    
17.     Next
    
18.   End With
    
19.   With Worksheets("研发明细账")
    
20.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
21.     arr = .Range("a2:j" & r)
    
22.     For i = 1 To UBound(arr)
    
23.       If Not d.exists(arr(i, 7)) Then
    
24.         Set d(arr(i, 7)) = CreateObject("scripting.dictionary")
    
25.       End If
    
26.       If Not d(arr(i, 7)).exists(arr(i, 1)) Then
    
27.         ReDim brr(1 To 37)
    
28.         brr(1) = Month(arr(i, 1))
    
29.         brr(2) = Day(arr(i, 1))
    
30.         brr(3) = arr(i, 2)
    
31.         brr(4) = arr(i, 3)
    
32.         brr(5) = arr(i, 4)
    
33.       Else
    
34.         brr = d(arr(i, 7))(arr(i, 1))
    
35.       End If
    
36.       brr(6) = brr(6) + arr(i, 5)
    
37.       brr(7) = brr(7) + arr(i, 6)
    
38.       If d1.exists(CStr(arr(i, 9))) Then
    
39.         n = d1(CStr(arr(i, 9)))
    
40.         brr(n) = brr(n) + arr(i, 5)
    
41.       End If
    
42.       d(arr(i, 7))(arr(i, 1)) = brr
    
43.       d2(arr(i, 7)) = arr(i, 8)
    
44.     Next
    
45.   End With
    
46.   On Error Resume Next
    
47.   For Each aa In d.keys
    
48.     Set ws = Worksheets(aa)
    
49.     If Not ws Is Nothing Then
    
50.       ws.Delete
    
51.     End If
    
52.   Next
    
53.   On Error GoTo 0
    
54.   For Each aa In d.keys
    
55.     Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    
56.     With ws
    
57.       .Name = aa
    
58.       Worksheets("模板").Range("a1:ak7").Copy .Range("a1")
    
59.       .Range("e2") = d2(aa)
    
60.       .Range("h2") = aa
    
61.       m = 7
    
62.       For Each bb In d(aa).keys
    
63.         brr = d(aa)(bb)
    
64.         m = m + 1
    
65.         .Cells(m, 1).Resize(1, UBound(brr)) = brr
    
66.       Next
    
67.       For j = 1 To UBound(lk)
    
68.         .Columns(j).ColumnWidth = lk(j)
    
69.       Next
    
70.       r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
71.       .Range("a3:ak" & r).Borders.LineStyle = xlContinuous
    
72.     End With
    
73.   Next
    
74. End Sub
    

复制代码

chxw68

详见附件。

cxd1001

chxw68 发表于 2017-3-8 20:26
详见附件。

还有几个问题能再解决下就更完美了
1、打开文件的时候，会自动打开两个文件，研发台账.xlsm:1和研发台账.xlsm:2，是什么原因？
2、模板的第8行即期初余额要复制过去
3、模板的最后一行第20行期末余额也要复制过去到相应台账的最后一张
4、模板H9:I19的公式能不能也复制到相应的表