汇总数据求提速

张雄友

_枫_ 发表于 2015-3-13 22:47
++++++++()

直接死机了。1000行已经慢得不成样子了。

yjh_27

张雄友 发表于 2015-3-14 13:11
直接死机了。1000行已经慢得不成样子了。

我的古董机  50s，你的？s

张雄友

yjh_27 发表于 2015-3-17 21:57
我的古董机  50s，你的？s

当员工生产二个以上工序时，能不能用个括号括上，如：（SU7890/SU7891/SU7892） 埋夹 33510件  ？

brr = YjhSort(arr, "a,a,a", "2,11,8", "C,8;2;3;0,14;2;3;1")  这个太复杂了，各个参数具体指什么？谢谢！

我测试速度很快。

yjh_27

张雄友 发表于 2015-3-17 22:11
当员工生产二个以上工序时，能不能用个括号括上，如：（SU7890/SU7891/SU7892） 埋夹 33510件  ？

brr ...

Function qch(s)
fl = Split(s, "|")
j0 = 0
For j = 1 To UBound(fl)
    If fl(j0) <> fl(j) Then
        j0 = j0 + 1
        fl(j0) = fl(j)
    End If
Next

qch = fl(0)
For j = 1 To j0
    qch = qch & "/" & fl(j)
Next
If j0 > 0 Then qch = "(" & qch & ")"
End Function

yjh_27

张雄友 发表于 2015-3-17 22:11
当员工生产二个以上工序时，能不能用个括号括上，如：（SU7890/SU7891/SU7892） 埋夹 33510件  ？

brr ...

arr  待统计数组
"a,a,a", "2,11,8"    按 制单号 、 工序名称、制单号  分组
"C,     统计
8;2;3;0,     统计8列，按 制单号 、 工序名称  分组 字符和

14;2;3;1"    统计14列，按 制单号 、 工序名称  分组  数字和

yjh_27

将去重复统计项的功能整合进统计自定义函数
提速5s

张雄友

cbtaja 发表于 2015-3-13 00:41
试试看，处理本例6万行数据在我的机器上用时约0.7秒：

黄色单元格这列怎么不对？

cbtaja

张雄友 发表于 2015-5-7 22:06
黄色单元格这列怎么不对？

第1笔的数量，直接取值；
后续各笔的数量，需要累计。

1. Sub cbtaja()
   
2. '第2列工号，第3列姓名，第8列制单号，第11列工序名称，第14列产量！
   
3. Dim arr, brr, d, d2, i&, j&, k&, zl&, r&, h&, l&, p&, t#, ghgx$, tmp
   
4. t = Timer
   
5. Set d = CreateObject("scripting.dictionary")
   
6. arr = Sheets("交飞明细").Range("A1").CurrentRegion
   
7. r = UBound(arr)
   
8. If r > 1 Then zl = 4 Else Exit Sub'如果有数据，则结果至少有4列。
   
9. ReDim brr(1 To 65535) '假设工人人数65535以内
   
10. ReDim crr(1 To 65535, 1 To 99) '假设工序99以内
    
11. For i = 2 To r
    
12.     arr(i, 2) = Format(arr(i, 2), String(8, "0")) '本厂工号不会超过8位数！
    
13.     ghgx = arr(i, 2) & arr(i, 11)
    
14.     If Not d.Exists(arr(i, 2)) Then
    
15.         h = h + 1
    
16.         d(arr(i, 2)) = h
    
17.         brr(h) = 4
    
18.         d(ghgx) = 4
    
19.         crr(h, 1) = arr(i, 2) '工号
    
20.         crr(h, 2) = arr(i, 3) '姓名
    
21.         crr(h, 3) = arr(i, 14) '第1笔的数量，直接取值
    
22.         crr(h, 4) = Array(arr(i, 8), arr(i, 11), arr(i, 14)) '单号、工序、数量
    
23.     Else
    
24.         p = d(arr(i, 2))
    
25.         '----------------------------------------------------------
    
26.         crr(p, 3) = crr(p, 3) + arr(i, 14) '后续各笔的数量，需要累计。
    
27.         '-----------------------------------------------------------
    
28.         If d.Exists(ghgx) Then
    
29.             l = d(ghgx) '从字典中查取已知工序的列号
    
30.             tmp = crr(p, l)
    
31.             tmp(2) = tmp(2) + arr(i, 14) '按工序累计
    
32.             If InStr(tmp(0), arr(i, 8)) = 0 Then tmp(0) = tmp(0) & "/" & arr(i, 8)
    
33.             crr(p, l) = tmp
    
34.         Else
    
35.             l = brr(p) + 1 '定位新工序的列，为该工号原有工序最大列号+1
    
36.             d(ghgx) = l '把工号工序对应的列号存入字典，以便后续累加时定位列号所需
    
37.             If zl < l Then zl = l '比较所有工号的最大列数
    
38.             brr(p) = l
    
39.             crr(p, l) = Array(arr(i, 8), arr(i, 11), arr(i, 14)) '新工号工序的单号、工序、数量
    
40.         End If
    
41.     End If
    
42. Next
    
43. For i = 1 To h
    
44.     For j = 2 To brr(i)
    
45.         If IsArray(crr(i, j)) Then
    
46.             If InStr(crr(i, j)(0), "/") > 0 Then crr(i, j)(0) = "(" & crr(i, j)(0) & ")"
    
47.             crr(i, j) = Join(crr(i, j), " ") & "件"
    
48.         End If
    
49.     Next
    
50. Next
    
51. With Sheets("get")
    
52. .Rows("2:65535").Delete '减轻负担！针对 clear 后遗证！
    
53. .Range("A2").Resize(h, zl) = crr
    
54. '.Range("A2").Resize(h, zl).EntireColumn.AutoFit
    
55. End With
    
56. MsgBox "用时" & Format(Timer - t, "0.00") & "秒"
    
57. End Sub
    

复制代码

张雄友

cbtaja 发表于 2015-5-8 22:20
第1笔的数量，直接取值；
后续各笔的数量，需要累计。

能不能排序的？谢谢了。

cbtaja

张雄友 发表于 2015-5-8 22:27
能不能排序的？谢谢了。

加一个排序代码，各个工号所做的工序种类不多，所以用最原始的冒泡法进行排序就行了。

1. Sub cbtaja()
   
2. '第2列工号，第3列姓名，第8列制单号，第11列工序名称，第14列产量！
   
3. Dim arr, brr, d, d2, i&, j&, k&, zl&, r&, h&, l&, p&, t#, ghgx$, tmp
   
4. t = Timer
   
5. Set d = CreateObject("scripting.dictionary")
   
6. arr = Sheets("交飞明细").Range("A1").CurrentRegion
   
7. r = UBound(arr)
   
8. If r > 1 Then zl = 4 Else Exit Sub '有明细中包含有效数据，则结果至少有4列
   
9. ReDim brr(1 To 65535) '假设工人人数65535以内
   
10. ReDim crr(1 To 65535, 1 To 99) '假设工序99以内
    
11. For i = 2 To r
    
12.     arr(i, 2) = Format(arr(i, 2), String(8, "0")) '本厂工号不会超过8位数！
    
13.     ghgx = arr(i, 2) & arr(i, 11)
    
14.     If Not d.Exists(arr(i, 2)) Then
    
15.         h = h + 1
    
16.         d(arr(i, 2)) = h
    
17.         brr(h) = 4
    
18.         d(ghgx) = 4
    
19.         crr(h, 1) = arr(i, 2) '工号
    
20.         crr(h, 2) = arr(i, 3) '姓名
    
21.         crr(h, 3) = arr(i, 14) '第1笔的数量，直接取值
    
22.         crr(h, 4) = Array(arr(i, 8), arr(i, 11), arr(i, 14)) '单号、工序、数量
    
23.     Else
    
24.         p = d(arr(i, 2))
    
25.         '----------------------------------------------------------
    
26.         crr(p, 3) = crr(p, 3) + arr(i, 14) '后续各笔的数量，需要累计。
    
27.         '-----------------------------------------------------------
    
28.         If d.Exists(ghgx) Then
    
29.             l = d(ghgx) '从字典中查取已知工序的列号
    
30.             tmp = crr(p, l)
    
31.             tmp(2) = tmp(2) + arr(i, 14) '按工序累计
    
32.             If InStr(tmp(0), arr(i, 8)) = 0 Then tmp(0) = tmp(0) & "/" & arr(i, 8)
    
33.             crr(p, l) = tmp
    
34.         Else
    
35.             l = brr(p) + 1 '定位新工序的列，为该工号原有工序最大列号+1
    
36.             d(ghgx) = l '把工号工序对应的列号存入字典，以便后续累加时定位列号所需
    
37.             If zl < l Then zl = l '比较所有工号的最大列数
    
38.             brr(p) = l
    
39.             crr(p, l) = Array(arr(i, 8), arr(i, 11), arr(i, 14)) '新工号工序的单号、工序、数量
    
40.         End If
    
41.     End If
    
42. Next
    
43. For i = 1 To h
    
44. '----------最原始的冒泡法排序------------------
    
45.     For j = 4 To brr(i)
    
46.         For k = j + 1 To brr(i)
    
47.             If crr(i, j)(2) < crr(i, k)(2) Then temp = crr(i, j): crr(i, j) = crr(i, k): crr(i, k) = temp
    
48.         Next
    
49.     Next
    
50. '----------------------------------------------
    
51.     For j = 4 To brr(i)
    
52.         If InStr(crr(i, j)(0), "/") > 0 Then crr(i, j)(0) = "(" & crr(i, j)(0) & ")"
    
53.         crr(i, j) = Join(crr(i, j), " ") & "件"
    
54.     Next
    
55. Next
    
56. With Sheets("get")
    
57. .Rows("2:65535").Delete '减轻负担！针对 clear 后遗证！
    
58. .Range("A2").Resize(h, zl) = crr
    
59. '.Range("A2").Resize(h, zl).EntireColumn.AutoFit
    
60. End With
    
61. MsgBox "用时" & Format(Timer - t, "0.00") & "秒"
    
62. End Sub
    

复制代码