根据多条件对文本进行合并，并计算求和

feiyang8878

求各位大神帮助，尽量简单数据量后期会大，万分感谢！

ykqrs

1. Sub qq()
   
2. Dim d, r&, i&, ar, s$, aa, bb, br, m&, s1, i1%
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. r = Cells(Rows.Count, 1).End(xlUp).Row
   
5. ar = Range("a2:g" & r)
   
6. For i = 1 To UBound(ar)
   
7. If Len(ar(i, 6)) Then
   
8. s = ar(i, 1) & "+" & ar(i, 2) & "+" & ar(i, 3) & "+" & ar(i, 4)
   
9. If Not d.exists(s) Then
   
10. Set d(s) = CreateObject("Scripting.Dictionary")
    
11. End If
    
12. d(s)(ar(i, 6)) = d(s)(ar(i, 6)) + ar(i, 7)
    
13. End If
    
14. Next
    
15. ReDim br(1 To d.Count, 1 To 5)
    
16. m = 0
    
17. For Each aa In d.keys
    
18. m = m + 1
    
19. For Each bb In d(aa).keys
    
20. br(m, 5) = br(m, 5) & "," & bb & "*" & d(aa)(bb)
    
21. Next
    
22. br(m, 5) = Mid(br(m, 5), 2)
    
23. s1 = Split(aa, "+")
    
24. For i1 = 1 To 4: br(m, i1) = s1(i1 - 1): Next
    
25. Next
    
26. With Sheets("报表")
    
27. .[a1].CurrentRegion.Offset(1).ClearContents
    
28. .[a2:e2].Resize(d.Count) = br
    
29. .Activate
    
30. End With
    
31. End Sub
    

复制代码

ykqrs

工作簿1.rar (20.56 KB, 下载次数: 1)

2019-4-17 10:15 上传

点击文件名下载附件

ykqrs

如果没有不良品记录，上面的代码出错

1. Sub qq()
   
2. Dim d, r&, i&, ar, s$, aa, bb, br, m&, s1, i1%
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. r = Cells(Rows.Count, 1).End(xlUp).Row
   
5. ar = Range("a2:g" & r)
   
6. For i = 1 To UBound(ar)
   
7. If Len(ar(i, 6)) Then
   
8. s = ar(i, 1) & "+" & ar(i, 2) & "+" & ar(i, 3) & "+" & ar(i, 4)
   
9. If Not d.exists(s) Then
   
10. Set d(s) = CreateObject("Scripting.Dictionary")
    
11. End If
    
12. d(s)(ar(i, 6)) = d(s)(ar(i, 6)) + ar(i, 7)
    
13. End If
    
14. Next
    
15. If d.Count Then
    
16. ReDim br(1 To d.Count, 1 To 5)
    
17. m = 0
    
18. For Each aa In d.keys
    
19. m = m + 1
    
20. For Each bb In d(aa).keys
    
21. br(m, 5) = br(m, 5) & "," & bb & "*" & d(aa)(bb)
    
22. Next
    
23. br(m, 5) = Mid(br(m, 5), 2)
    
24. s1 = Split(aa, "+")
    
25. For i1 = 1 To 4: br(m, i1) = s1(i1 - 1): Next
    
26. Next
    
27. With Sheets("报表")
    
28. .[a1].CurrentRegion.Offset(1).ClearContents
    
29. .[a2:e2].Resize(d.Count) = br
    
30. .Activate
    
31. End With
    
32. Else
    
33. Exit Sub
    
34. End If
    
35. End Sub
    

复制代码

feiyang8878

感谢帮忙，如果我在两个表前面在加入一列日期呢，根据  日期        班次        生产线        产品名称        产品零件号
  这5个字段条件进行合并计算，附件中我没有加入

feiyang8878

还有一点是怎样在不使用按钮时触，或者用函数有没有更合适的方法