字典合并，并输出

335356119

我想把图片中的考勤明细和产量明细，经过处理后，自动填充到产量考勤汇总的表格里。之前坛友帮助提供的代码已经能解决问题了。但我想把代码综合起来，节约计算时间。
考勤的汇总，根据汇总表格里，已经填写的组别次序，自动填充姓名/人数/小组工时（小组工时用同组人员的下班时间总和-上班时间总和-休息时间总和）。
产量的汇总，同组生产的不同产品名称（次数）的，其产品名，加工产量，人均产量，需要在同单元格下一一对应的以“/”分割开。（第一张图没有填写产品，产量，平均产量的样式，第四张（简配版，效果应该是填写在第一张图）是。


谢谢@不知道为什么以及各位提供的热心帮助，由于我vba不精通，又使用了函数进行辅助。两端代码完美使用，本来我想这想尝试把这两段代码综合到一起使用。发现涉及到字典keys对应的问题，小弟无力解决，求各位帮助。两端代码应以附件中“小组”编号为 Keys ，进行查询填充文字。

1. Sub 更新考勤()
   
2.     Dim Dic, Arr, Brr()
   
3.     Set Dic = CreateObject("scripting.dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     With Sheets("考勤明细")
   
6.         Arr = .[a1].CurrentRegion
   
7.         For i = 2 To UBound(Arr)
   
8.             If Not Dic.exists(DateValue(Arr(i, 1))) Then
   
9.                 Set Dic(DateValue(Arr(i, 1))) = CreateObject("scripting.dictionary")
   
10.             End If
    
11.             If Not Dic(Arr(i, 1)).exists(Arr(i, 3)) Then
    
12.                 Set Dic(DateValue(Arr(i, 1)))(Arr(i, 3)) = CreateObject("scripting.dictionary")
    
13.             End If
    
14.             Dic(DateValue(Arr(i, 1)))(Arr(i, 3))(Arr(i, 2)) = Dic(DateValue(Arr(i, 1)))(Arr(i, 3))(Arr(i, 2)) + 1
    
15.         Next i
    
16.     End With
    
17.     ReDim Brr(1 To UBound(Arr), 1 To 9)
    
18.     With Sheets("产量考勤汇总")
    
19.         .[h3].Resize(1000, 9).ClearContents
    
20.         If Dic.exists(DateValue(.Range("a1"))) Then
    
21.             For Each k In Dic(DateValue(.Range("a1"))).keys
    
22.             x = x + 1
    
23.             Brr(x, 8) = k
    
24.             For Each kl In Dic(DateValue(.Range("a1")))(k).keys
    
25.                 Brr(x, 9) = Join(Dic(DateValue(.Range("a1")))(k).keys, " ")
    
26.                 Brr(x, 6) = Dic(DateValue(.Range("a1")))(k).Count
    
27.                 Next
    
28.             Next
    
29.         End If
    
30.         If x Then
    
31.             .[h3].Resize(x, 9) = Brr
    
32.         End If
    
33.     End With
    
34.     Set Dic = Nothing
    
35.     Application.ScreenUpdating = True
    
36. End Sub
    
37. 
    

复制代码

1. Sub 更新产量()
   
2.     Dim Dic, Arr, Brr()
   
3.     Set Dic = CreateObject("scripting.dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Arr = Sheets("产量明细").[a1].CurrentRegion
   
6.     ReDim Brr(1 To UBound(Arr), 1 To 10)
   
7.     For i = 2 To UBound(Arr)
   
8.         rq = DateValue(Arr(i, 1))
   
9.         If Not Dic.exists(rq) Then
   
10.             Set Dic(rq) = CreateObject("scripting.dictionary")
    
11.         End If
    
12.         
    
13.         If Not Dic(rq).exists(Arr(i, 3)) Then
    
14.             Set Dic(rq)(Arr(i, 3)) = CreateObject("scripting.dictionary")
    
15.         End If
    
16.         Dic(rq)(Arr(i, 3))(Arr(i, 2)) = Dic(rq)(Arr(i, 3))(Arr(i, 2)) + Arr(i, 5)
    
17.     Next i
    
18.     With Sheets("产量考勤汇总")
    
19.         rq = DateValue(.Cells(1, 1))
    
20.         If Dic.exists(rq) Then
    
21.             For Each k In Dic(rq).keys
    
22.                 x = x + 1
    
23.                 Brr(x, 6) = k
    
24.            For i = 2 To UBound(Arr)
    
25.              If DateValue(Arr(i, 1)) = rq And Arr(i, 3) = k Then
    
26.                 s = s + 1
    
27.              End If
    
28.            Next i
    
29.            Brr(x, 4) = s: s = 0
    
30.                 For Each k1 In Dic(rq)(k).keys
    
31.                     Brr(x, 1) = Join(Dic(rq)(k).keys, "/")
    
32.                     Brr(x, 3) = Join(Dic(rq)(k).items, "/")
    
33.                 Next
    
34.             Next
    
35.         End If
    
36.         For i = 1 To x
    
37.             If InStr(Brr(i, 3), "/") Then
    
38.                 For n = 0 To UBound(Split(Brr(i, 3), "/"))
    
39.                     pj = Val(Split(Brr(i, 3), "/")(n)) \ Brr(i, 4)
    
40.                     mm = mm & "/" & pj
    
41.                 Next n
    
42.                 Brr(i, 5) = Right(mm, Len(mm) - 1): mm = ""
    
43.             Else
    
44.                 Brr(i, 5) = Brr(i, 3) \ Brr(i, 4)
    
45.             End If
    
46.         Next i
    
47.          .[a3:f999].ClearContents
    
48.         .[a3].Resize(x, 6) = Brr
    
49.         .Activate
    
50.     End With
    
51.     Set Dic = Nothing
    
52.     Application.ScreenUpdating = True
    
53. End Sub

复制代码

335356119

工件统计考勤.rar (23.27 KB, 下载次数: 20)

2018-9-16 15:30 上传

点击文件名下载附件

lsc900707

335356119 发表于 2018-9-16 15:30

此类问题最好先找当事人解决。

335356119

求教@不知道为什么

335356119

求教求教求教

chxw68

335356119 发表于 2018-9-17 07:21
求教求教求教

分析代码太费劲了，楼主直接说说你的需求，重新写个代码还简单。

335356119

chxw68 发表于 2018-9-17 08:03
分析代码太费劲了，楼主直接说说你的需求，重新写个代码还简单。

产量考勤的汇总sheet分别从两个表格中提取数据
考勤明细sheet的汇总，根据汇总表格里，已经填写的组别次序，自动填充姓名/人数/小组工时（小组工时用同组人员的下班时间总和-上班时间总和-休息时间总和）。（见图1）
产量明细sheet的汇总，同组生产的不同产品名称（次数）的，其产品名，加工产量，人均产量，需要在同单元格下一一对应的以“/”分割开。（第一张图没有填写产品，产量，平均产量的样式，第四张（简配版，效果应该是填写在第一张图）是。

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.   With Worksheets("产量考勤汇总")
   
8.     rq = .Range("a1")
   
9.   End With
   
10.   With Worksheets("考勤明细")
    
11.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
12.     arr = .Range("a2:f" & r)
    
13.     For i = 1 To UBound(arr)
    
14.       If arr(i, 1) = rq Then
    
15.         If Not d.exists(arr(i, 3)) Then
    
16.           ReDim brr(1 To 7)
    
17.           brr(6) = arr(i, 3)
    
18.           Set brr(7) = CreateObject("scripting.dictionary")
    
19.         Else
    
20.           brr = d(arr(i, 3))
    
21.         End If
    
22.         brr(7)(arr(i, 2)) = ""
    
23.         brr(2) = brr(2) + arr(i, 5) - arr(i, 4)
    
24.         d(arr(i, 3)) = brr
    
25.       End If
    
26.     Next
    
27.   End With
    
28.   With Worksheets("产量明细")
    
29.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
30.     arr = .Range("a2:e" & r)
    
31.     For i = 1 To UBound(arr)
    
32.       If arr(i, 1) = rq Then
    
33.         If Not d1.exists(arr(i, 3)) Then
    
34.           Set d1(arr(i, 3)) = CreateObject("scripting.dictionary")
    
35.         End If
    
36.         d1(arr(i, 3))(arr(i, 2)) = d1(arr(i, 3))(arr(i, 2)) + arr(i, 5)
    
37.       End If
    
38.     Next
    
39.   End With
    
40.         
    
41.       
    
42.   With Worksheets("产量考勤汇总")
    
43.     .Range("a3:e22,g3:g22").ClearContents
    
44.     arr = .Range("a3:g22")
    
45.     For i = 1 To UBound(arr)
    
46.       If d.exists(arr(i, 6)) Then
    
47.         brr = d(arr(i, 6))
    
48.         brr(4) = brr(7).Count
    
49.         brr(7) = Join(brr(7).keys, " ")
    
50.         For j = 1 To UBound(brr)
    
51.           arr(i, j) = brr(j)
    
52.         Next
    
53.         If d1.exists(arr(i, 6)) Then
    
54.           arr(i, 1) = Join(d1(arr(i, 6)).keys, "/")
    
55.           ReDim crr(1 To d1(arr(i, 6)).Count)
    
56.           m = 0
    
57.           For Each bb In d1(arr(i, 6)).keys
    
58.             m = m + 1
    
59.             crr(m) = Round(d1(arr(i, 6))(bb) / arr(i, 4), 2)
    
60.           Next
    
61.           arr(i, 3) = Join(d1(arr(i, 6)).items, "/")
    
62.           arr(i, 5) = Join(crr, "/")
    
63.         End If
    
64.       End If
    
65.     Next
    
66.     .Range("a3:g22") = arr
    
67.   End With
    
68. End Sub
    

复制代码

chxw68

详见附件。