想将个工作表的数据汇总到一张表内

h0wezheng

各位大侠
麻烦编一个程序


如附件“汇总 (希望效果)”sheet那样，将数据汇总到一张表格内
注意
1、“编号”列的项目不是每个都固定，希望自动识别到没有数据就停止
2、有些产品"模号"不止4个，有些只有一个，希望根据工作表中的“模号”自动识别
3、工作表不止案例中的数量，希望根据实际有几个自动汇总


感激不尽。

ykcbf1100

终算完成了。此题处理起来有点烦。

ykcbf1100

参与一下吧。

1. Sub ykcbf()  '//2024.6.27
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set d1 = CreateObject("Scripting.Dictionary")
   
5.     Set sh = ThisWorkbook.Sheets("汇总")
   
6.     n = 6
   
7.     ReDim brr(1 To 10000, 1 To 100)
   
8.     ReDim zrr(1 To 1, 1 To 100)
   
9.     For Each sht In Sheets
   
10.         If InStr(sht.Name, "#") Then
    
11.             With sht
    
12.                 arr = .UsedRange
    
13.                 bm = arr(1, 2)
    
14.                 d1(bm) = d1(bm) + 1
    
15.                 If Not d.exists(bm) Then
    
16.                     c = c + 2
    
17.                     d(bm) = c
    
18.                     zrr(1, c - 1) = bm
    
19.                 End If
    
20.             End With
    
21.             c = d(bm)
    
22.             k = d1(bm)
    
23.             For i = 3 To UBound(arr)
    
24.                 If arr(i, 2) <> Empty Then
    
25.                     s = arr(i, 2) & "|" & arr(i, 7) & "|" & k
    
26.                     If Not d.exists(s) Then
    
27.                         m = m + 1
    
28.                         d(s) = m
    
29.                     End If
    
30.                     r = d(arr(i, 2) & "|" & arr(i, 7) & "|" & k)
    
31.                     For j = 2 To 7
    
32.                         brr(r, j - 1) = arr(i, j)
    
33.                     Next
    
34.                     brr(r, n + c - 1) = arr(i, 8)
    
35.                     brr(r, n + c) = arr(i, 9)
    
36.                 End If
    
37.             Next
    
38.         End If
    
39.     Next
    
40.     With sh
    
41.         .Cells.UnMerge
    
42.         .[h2:z10000].ClearContents
    
43.         .[b3:g10000].Clear
    
44.         .[h2].Resize(1, c) = zrr
    
45.         .[b2].Resize(1, 6 + c).Interior.Color = 49407
    
46.         .[c2:d2].Merge
    
47.         For j = 8 To c + 7 Step 2
    
48.             .Cells(2, j).Resize(, 2).Merge
    
49.         Next
    
50.         With .[b3].Resize(m, 6 + c)
    
51.             .Value = brr
    
52.             .Borders.LineStyle = 1
    
53.             .HorizontalAlignment = xlCenter
    
54.             .VerticalAlignment = xlCenter
    
55.         End With
    
56.     End With
    
57.     Set d = Nothing
    
58.     Application.ScreenUpdating = True
    
59.     MsgBox "OK！"
    
60. End Sub
    
61. 
    
62. 
    

复制代码

h0wezheng

ykcbf1100 发表于 2024-6-27 21:47
参与一下吧。

首先很感谢大哥你的协助，怎么我出来的效果不一样

ykcbf1100

h0wezheng 发表于 2024-6-28 08:50
首先很感谢大哥你的协助，怎么我出来的效果不一样

你的电脑能用xlsm文件吗？运行xls文件会有点问题。
我这里正常的。

h0wezheng

ykcbf1100 发表于 2024-6-28 09:36
你的电脑能用xlsm文件吗？运行xls文件会有点问题。
我这里正常的。

谢谢真的是我后缀的问题。

另外，我想改变LOT NO.获取数据位置修改哪里
例如数据源在C2想变成C9,麻烦告知

ykcbf1100

h0wezheng 发表于 2024-6-29 15:51
谢谢真的是我后缀的问题。

另外，我想改变LOT NO.获取数据位置修改哪里

你上附件说明一下吗？