[已解决]同一文件内根据明细表按汇总及分类汇总，明细表数据复制到汇总表不重复

su45

8月.zip (811.75 KB, 下载次数: 29)

2016-10-14 23:52 上传

点击文件名下载附件

jsjtyjp_00

su45 发表于 2016-10-14 23:52

老师：
     早上好！
     看您发贴时间，已是晚上近12点了。辛苦您了。非常感谢！

     测试了，好用。再次感谢！

jsjtyjp_00

jsjtyjp_00 发表于 2016-10-15 09:00
老师：
     早上好！
     看您发贴时间，已是晚上近12点了。辛苦您了。非常感谢！

老师：

晚上好！

当我在“复制取数汇总表“将所有人的“单件工分”等数据填好后，再在“按单号汇总”表上点击“按钮1”进行汇总时，报“下标越界”而无法汇总。

怪我开始图省，只举了前4人的例子，且没说清，误导您了。请原谅。

实际上是要汇总所有人的。一个车间约300多人，1个月下来，在“复制取数汇总表“的记录近1万行，需要在这所有的行数中按单号、人名进行汇总。

一个统计期内，同一人同一单号，从事几道工序，无规律，一个统计期内，同一人，涉及几个工序也没规律。

老师麻烦您了。谢谢。

8月(1016).rar (501.97 KB, 下载次数: 5)

2016-10-16 21:30 上传

点击文件名下载附件

jsjtyjp_00

su45 发表于 2016-10-14 23:52

老师：
      晚上好！
     当“复制取数汇总表“中数据达到一定的量后，再”在“小计/完成数”栏内非0的单元格对应的“单件工分”单元格内输入数据时，就会报“下标越界”。是什么原因呢？
     谢谢！
8月1017求教.rar (509.03 KB, 下载次数: 9)

2016-10-17 20:03 上传

点击文件名下载附件

su45

不会的，“按单号汇总”中的按钮与你说的这几列都没关系！

su45

我这里是没发现问题

jsjtyjp_00

su45 发表于 2016-10-17 22:42
我这里是没发现问题

老师：
     早上好！
     您是在“单件工分（CX栏）“44行黄色单元格或其他”小计/完成数“非0的单元格所对应的”单件工分“单元格中输入1以上的数据的吗。
     我用的是office2016，这会有影响吗。
     谢谢！
   
我又分别在OFFICE2007和OFFICE2010上试也是这样，全部输入数据后，就会报“下标越界。

su45

“按单号汇总”中的按钮中的代码只与A、B、C、D 和最后一列有关！与你说的这几列没丝毫关系！

su45

你把你出错的文件发过来试试！不要拿这里的附件给我！

su45

与填没填数字无关，但找到一个问题，改了下代码：

1. Sub suab()
   
2. Application.ScreenUpdating = False
   
3. With Sheets("复制取数汇总表")
   
4.     rw = .Cells(Rows.Count, 1).End(3).Row
   
5.     ar1 = .Range("A4:D" & rw)
   
6.     Set gf = .Rows("2:3").Find("合计工分")
   
7.     If gf Is Nothing Then Exit Sub
   
8.     ar2 = gf.Offset(1, 0).Resize(rw - 3, 1)
   
9. End With
   
10. Set d1 = CreateObject("Scripting.Dictionary")
    
11. Set d2 = CreateObject("Scripting.Dictionary")
    
12. For i = 1 To UBound(ar1)
    
13.     x = ar1(i, 1) & ":" & ar1(i, 3) & ":" & ar1(i, 4)
    
14.     d1(x) = d1(x) + ar2(i, 1)
    
15.     d2(ar1(i, 3) & ":" & ar1(i, 4)) = d2(ar1(i, 3) & ":" & ar1(i, 4)) + ar2(i, 1)
    
16. Next
    
17. s1 = d1.keys
    
18. s2 = d2.keys
    
19. s3 = s1
    
20. ReDim dhhz(1 To UBound(s1) * 2 + 2, 1 To 4)
    
21. ReDim ryhz(1 To UBound(s2) + 1, 1 To 4)
    
22. C = a
    
23. For i = 0 To UBound(s1)
    
24.     If d1(s1(i)) <> 0 Then
    
25.         x = Split(s1(i), ":")(1) & ":" & Split(s1(i), ":")(2)
    
26.         For j = 0 To UBound(s3)
    
27.             
    
28.             If InStr(s3(j), x) Then
    
29.                 a = a + 1
    
30.                 dhhz(a, 1) = Split(s3(j), ":")(0)
    
31.                 dhhz(a, 2) = Split(s3(j), ":")(1)
    
32.                 dhhz(a, 3) = Split(s3(j), ":")(2)
    
33.                 dhhz(a, 4) = d1(s3(j))
    
34.                 s3(j) = 0
    
35.             End If
    
36.         Next
    
37.         If a > C Then
    
38.             a = a + 1
    
39.             dhhz(a, 1) = "合计": dhhz(a, 4) = d2(x)
    
40.             C = a
    
41.         End If
    
42.     End If
    
43. Next
    
44. With Sheets("按单号汇总")
    
45.     rw = .Cells(Rows.Count, 1).End(3).Row
    
46.     If rw > 3 Then .Rows("4:" & rw).Delete
    
47.     .Range("A4").Resize(a, 4) = dhhz
    
48.     .Range("A4:D" & a + 3).Borders.LineStyle = 1
    
49.     m = 4
    
50.     Do While .Cells(m, 1) <> ""
    
51.         If .Cells(m, 1) = "合计" Then
    
52.             .Range(.Cells(m, 1), .Cells(m, 4)).Font.ColorIndex = 3
    
53.             .Range(.Cells(m, 1), .Cells(m, 4)).Font.Bold = True
    
54.         End If
    
55.         m = m + 1
    
56.     Loop
    
57. End With
    
58. For i = 0 To UBound(s2)
    
59.     If d2(s2(i)) <> 0 Then
    
60.         b = b + 1
    
61.         ryhz(b, 1) = "合计"
    
62.         ryhz(b, 2) = Split(s2(i), ":")(0)
    
63.         ryhz(b, 3) = Split(s2(i), ":")(1)
    
64.         ryhz(b, 4) = d2(s2(i))
    
65.     End If
    
66. Next
    
67. With Sheets("按人员汇总")
    
68.     rw = .Cells(Rows.Count, 1).End(3).Row
    
69.     If rw > 3 Then .Rows("4:" & rw).Delete
    
70.     .Range("A4").Resize(b, 4) = ryhz
    
71.     .Range("A4:D" & b + 3).Borders.LineStyle = 1
    
72. End With
    
73. End Sub
    

复制代码