汇总生成复杂的合并单元格样式，求代码

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.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
9.     arr = .Range("a2:l" & r)
   
10.   End With
    
11.   n = 0
    
12.   For i = 1 To UBound(arr)
    
13.     If Not d1.exists(arr(i, 8)) Then
    
14.       n = n + 1
    
15.       d1(arr(i, 8)) = n
    
16.     End If
    
17.   Next
    
18.   For i = 1 To UBound(arr)
    
19.     If Not d.exists(arr(i, 1)) Then
    
20.       Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    
21.     End If
    
22.     If Not d(arr(i, 1)).exists(arr(i, 2)) Then
    
23.       Set d(arr(i, 1))(arr(i, 2)) = CreateObject("scripting.dictionary")
    
24.       d(arr(i, 1))(arr(i, 2))(1) = arr(i, 4)
    
25.       Set d(arr(i, 1))(arr(i, 2))(2) = CreateObject("scripting.dictionary")
    
26.     End If
    
27.     If Not d(arr(i, 1))(arr(i, 2))(2).exists(arr(i, 5)) Then
    
28.       ReDim brr(1 To d1.Count)
    
29.     Else
    
30.       brr = d(arr(i, 1))(arr(i, 2))(2)(arr(i, 5))
    
31.     End If
    
32.     n = d1(arr(i, 8))
    
33.     brr(n) = brr(n) + arr(i, 12)
    
34.     d(arr(i, 1))(arr(i, 2))(2)(arr(i, 5)) = brr
    
35.   Next
    
36.   With Worksheets("汇总表")
    
37.     .UsedRange.Offset(1, 0).Clear
    
38.     m = 2
    
39.     For Each aa In d.keys
    
40.       m0 = m
    
41.       For Each bb In d(aa).keys
    
42.         m1 = m
    
43.         For Each cc In d(aa)(bb)(2).keys
    
44.           brr = d(aa)(bb)(2)(cc)
    
45.           .Cells(m, 4) = cc
    
46.           .Cells(m, 5).Resize(1, UBound(brr)) = brr
    
47.           m = m + 1
    
48.         Next
    
49.         With .Cells(m1, 2)
    
50.           .Value = bb
    
51.           .Resize(m - m1, 1).Merge
    
52.         End With
    
53.         With .Cells(m1, 3)
    
54.           .Value = d(aa)(bb)(1)
    
55.           .Resize(m - m1, 1).Merge
    
56.         End With
    
57.       Next
    
58.       With .Cells(m0, 1)
    
59.         .Value = aa
    
60.         .Resize(m - m0, 1).Merge
    
61.       End With
    
62.     Next
    
63.     With .UsedRange
    
64.       .HorizontalAlignment = xlCenter
    
65.       .VerticalAlignment = xlCenter
    
66.     End With
    
67.     .Range("a1:g" & m - 1).Borders.LineStyle = xlContinuous
    
68.   End With
    
69. End Sub
    

复制代码

chxw68

先处理成这样，再根据楼主意见修改吧。

罗达

chxw68 发表于 2019-3-11 10:50
先处理成这样，再根据楼主意见修改吧。

这几天出差没看论坛，感谢你的帮助！马上测试

罗达

朱荣兴 发表于 2019-3-11 10:54
以这个为准：
Sub 汇总()
Application.ScreenUpdating = False

出差没来论坛，感谢帮助，马上测试。
测试结果：合并做到了，但是没汇总。

罗达

chxw68 发表于 2019-3-11 09:22
如果班组甲生产的“白糖/糖沙/1903001”既有没规格的，也有100g/袋 粉的，工时数怎么放置？

实际是包装之前只分炮制规格，包装时再分包装规格

罗达

chxw68 发表于 2019-3-11 10:50
先处理成这样，再根据楼主意见修改吧。

十分接近要求，若能去掉横杠“——”，将班组甲的工时显示合并就完美了

chxw68

像成品名称中的糖沙、原味豆干都可以合并，但麻辣豆干的班组甲数据怎么合并？能做个示例传上来吗？