[已解决]如何用 VBA 将多重条件的数据合并到一个单元格

toylife

如何用 VBA 将多重条件的数据合并到一个单元格
条件需要根据 生产日期        产品型号        生产线        班组        不良类型 将不良位置汇总到一起，并计算不良数量 生产数量只在第一列显示
具体实现效果 如附件内容


工作簿.zip (11.42 KB, 下载次数: 92)

2013-7-11 07:43 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-7-11 10:50

1. Sub 合并数据()
   
2.     Dim arr, arrResult
   
3.     Dim i As Long, j As Long, k As Long
   
4.     Dim strKey As String
   
5.     Dim lCount As Long, lPos As Long, arrPos
   
6.     Dim objDic As Object
   
7.     Dim strLast As String
   
8.     Set objDic = CreateObject("scripting.dictionary")
   
9. 
   
10.     arr = Sheet1.Range("a1").CurrentRegion
    
11.     If Not IsArray(arr) Then
    
12.         MsgBox "数据不符合要求"
    
13.         Exit Sub
    
14.     End If
    
15. 
    
16.     ReDim arrResult(1 To UBound(arr), 1 To UBound(arr, 2))
    
17. 
    
18.     For j = LBound(arr, 2) To UBound(arr, 2)
    
19.         arrResult(1, j) = arr(1, j)
    
20.     Next
    
21. 
    
22.     lCount = 1
    
23.     k = UBound(arrResult, 2)
    
24.     For i = LBound(arr) + 1 To UBound(arr)
    
25.         strKey = arr(i, 1) & "#" & arr(i, 5) & "#" & arr(i, 6) & "#" & arr(i, 7) & "#" & arr(i, 8)
    
26.         If objDic.exists(strKey) Then
    
27.             lPos = objDic(strKey)
    
28.             arrResult(lPos, 9) = arrResult(lPos, 9) & " " & arr(i, 9)
    
29.             arrResult(lPos, 10) = arrResult(lPos, 10) + arr(i, 10)
    
30.         Else
    
31.             lCount = lCount + 1
    
32.             objDic.Add strKey, lCount
    
33.             lPos = lCount
    
34.             For j = LBound(arr, 2) To k
    
35.                 arrResult(lPos, j) = arr(i, j)
    
36.             Next
    
37.             If arrResult(lPos, 7) = arrResult(lPos - 1, 7) And arrResult(lPos, 6) = arrResult(lPos - 1, 6) And arrResult(lPos, 5) = arrResult(lPos - 1, 5) Then
    
38.                 arrResult(lPos, k) = ""
    
39.             End If
    
40.         End If
    
41.     Next
    
42. 
    
43.     'With Sheet2
    
44.     '.UsedRange.ClearContents
    
45.     '.Range("a1").Resize(lCount, k).Value = arrResult
    
46.     'end with
    
47.    
    
48.     Worksheets.Add
    
49.     Range("a1").Resize(lCount, k).Value = arrResult
    
50.    
    
51.     MsgBox "合并完成"
    
52.    
    
53. End Sub
    

复制代码

跳转到最佳答案楼层

从从容容

让人费解.无法看明白.

hwc2ycy

1. Sub 合并数据()
   
2.     Dim arr, arrResult
   
3.     Dim i As Long, j As Long
   
4.     Dim strKey As String
   
5.     Dim lCount As Long, lPos As Long, arrPos
   
6.     Dim objDic As Object
   
7.     Set objDic = CreateObject("scripting.dictionary")
   
8.    
   
9.    
   
10.     arr = Sheet1.Range("a1").CurrentRegion
    
11.     If Not IsArray(arr) Then
    
12.         MsgBox "数据不符合要求"
    
13.         Exit Sub
    
14.     End If
    
15.    
    
16.    
    
17.     ReDim arrResult(1 To UBound(arr), 1 To UBound(arr))
    
18.    
    
19.     For j = LBound(arr, 2) To UBound(arr, 2)
    
20.         arrResult(1, j) = arr(1, j)
    
21.     Next
    
22. 
    
23.     lCount = 1
    
24. 
    
25.     For i = LBound(arr) + 1 To UBound(arr)
    
26.         strKey = arr(i, 1) & "#" & arr(i, 5) & "#" & arr(i, 6) & "#" & arr(i, 7) & "#" & arr(i, 8)
    
27.         If objDic.exists(strKey) Then
    
28.             lPos = objDic(strKey)
    
29.             arrResult(lPos, 9) = arrResult(lPos, 9) & " " & arr(i, 9)
    
30.             arrResult(lPos, 10) = arrResult(lPos, 10) + arr(i, 10)
    
31.         Else
    
32.             lCount = lCount + 1
    
33.             objDic.Add strKey, lCount
    
34.             lPos = lCount
    
35.             For j = LBound(arr, 2) To UBound(arr, 2)
    
36.                 arrResult(lPos, j) = arr(i, j)
    
37.             Next
    
38.         End If
    
39. 
    
40.     Next
    
41.     With Sheet2
    
42.         .UsedRange.ClearContents
    
43.         .Range("a1").Resize(lCount, UBound(arr, 2)).Value = arrResult
    
44.     End With
    
45.     MsgBox "合并完成"
    
46. End Sub

复制代码

toylife

hwc2ycy 发表于 2013-7-11 09:32

谢 烟花老师，还有个问题 就是产量只在第一个数据显示

删除备注
更新附件
请帮忙修改


工作簿.rar (10.57 KB, 下载次数: 77)

2013-7-11 09:42 上传

点击文件名下载附件

hwc2ycy

1. Sub 合并数据()
   
2.     Dim arr, arrResult
   
3.     Dim i As Long, j As Long
   
4.     Dim strKey As String
   
5.     Dim lCount As Long, lPos As Long, arrPos
   
6.     Dim objDic As Object
   
7.     Dim strLast As String
   
8.     Set objDic = CreateObject("scripting.dictionary")
   
9. 
   
10. 
    
11.     arr = Sheet1.Range("a1").CurrentRegion
    
12.     If Not IsArray(arr) Then
    
13.         MsgBox "数据不符合要求"
    
14.         Exit Sub
    
15.     End If
    
16. 
    
17. 
    
18.     ReDim arrResult(1 To UBound(arr), 1 To UBound(arr, 2))
    
19. 
    
20.     For j = LBound(arr, 2) To UBound(arr, 2)
    
21.         arrResult(1, j) = arr(1, j)
    
22.     Next
    
23. 
    
24.     lCount = 1
    
25. 
    
26.     For i = LBound(arr) + 1 To UBound(arr)
    
27.         strKey = arr(i, 1) & "#" & arr(i, 5) & "#" & arr(i, 6) & "#" & arr(i, 7) & "#" & arr(i, 8)
    
28.         If objDic.exists(strKey) Then
    
29.             lPos = objDic(strKey)
    
30.             arrResult(lPos, 9) = arrResult(lPos, 9) & " " & arr(i, 9)
    
31.             arrResult(lPos, 10) = arrResult(lPos, 10) + arr(i, 10)
    
32.         Else
    
33.             lCount = lCount + 1
    
34.             objDic.Add strKey, lCount
    
35.             lPos = lCount
    
36.             For j = LBound(arr, 2) To UBound(arr, 2)
    
37.                 arrResult(lPos, j) = arr(i, j)
    
38.             Next
    
39.         End If
    
40.     Next
    
41. 
    
42.     j = UBound(arrResult, 2)
    
43. 
    
44.     For i = LBound(arrResult) + 1 To lCount
    
45.         If arrResult(i, 7) = arrResult(i - 1, 7) Then
    
46.             arrResult(i, j) = ""
    
47.         End If
    
48.     Next
    
49.     With Sheet2
    
50.         .UsedRange.ClearContents
    
51.         .Range("a1").Resize(lCount, UBound(arr, 2)).Value = arrResult
    
52.     End With
    
53.     MsgBox "合并完成"
    
54. End Sub

复制代码

hwc2ycy

上面的有点问题，判断条件不完善。

1. Sub 合并数据()
   
2.     Dim arr, arrResult
   
3.     Dim i As Long, j As Long, k As Long
   
4.     Dim strKey As String
   
5.     Dim lCount As Long, lPos As Long, arrPos
   
6.     Dim objDic As Object
   
7.     Dim strLast As String
   
8.     Set objDic = CreateObject("scripting.dictionary")
   
9. 
   
10.     arr = Sheet1.Range("a1").CurrentRegion
    
11.     If Not IsArray(arr) Then
    
12.         MsgBox "数据不符合要求"
    
13.         Exit Sub
    
14.     End If
    
15. 
    
16.     ReDim arrResult(1 To UBound(arr), 1 To UBound(arr, 2))
    
17. 
    
18.     For j = LBound(arr, 2) To UBound(arr, 2)
    
19.         arrResult(1, j) = arr(1, j)
    
20.     Next
    
21. 
    
22.     lCount = 1
    
23.     k = UBound(arrResult, 2)
    
24.     For i = LBound(arr) + 1 To UBound(arr)
    
25.         strKey = arr(i, 1) & "#" & arr(i, 5) & "#" & arr(i, 6) & "#" & arr(i, 7) & "#" & arr(i, 8)
    
26.         If objDic.exists(strKey) Then
    
27.             lPos = objDic(strKey)
    
28.             arrResult(lPos, 9) = arrResult(lPos, 9) & " " & arr(i, 9)
    
29.             arrResult(lPos, 10) = arrResult(lPos, 10) + arr(i, 10)
    
30.         Else
    
31.             lCount = lCount + 1
    
32.             objDic.Add strKey, lCount
    
33.             lPos = lCount
    
34.             For j = LBound(arr, 2) To k
    
35.                 arrResult(lPos, j) = arr(i, j)
    
36.             Next
    
37.             If arrResult(lPos, 7) = arrResult(lPos - 1, 7) And arrResult(lPos, 6) = arrResult(lPos - 1, 6) Then
    
38.                 arrResult(lPos, k) = ""
    
39.             End If
    
40.         End If
    
41.     Next
    
42. 
    
43.     'With Sheet2
    
44.     '.UsedRange.ClearContents
    
45.     '.Range("a1").Resize(lCount, k).Value = arrResult
    
46.     'end with
    
47.    
    
48.     Worksheets.Add
    
49.     Range("a1").Resize(lCount, k).Value = arrResult
    
50.    
    
51.     MsgBox "合并完成"
    
52.    
    
53. End Sub

复制代码

hwc2ycy

1. Sub 合并数据()
   
2.     Dim arr, arrResult
   
3.     Dim i As Long, j As Long, k As Long
   
4.     Dim strKey As String
   
5.     Dim lCount As Long, lPos As Long, arrPos
   
6.     Dim objDic As Object
   
7.     Dim strLast As String
   
8.     Set objDic = CreateObject("scripting.dictionary")
   
9. 
   
10.     arr = Sheet1.Range("a1").CurrentRegion
    
11.     If Not IsArray(arr) Then
    
12.         MsgBox "数据不符合要求"
    
13.         Exit Sub
    
14.     End If
    
15. 
    
16.     ReDim arrResult(1 To UBound(arr), 1 To UBound(arr, 2))
    
17. 
    
18.     For j = LBound(arr, 2) To UBound(arr, 2)
    
19.         arrResult(1, j) = arr(1, j)
    
20.     Next
    
21. 
    
22.     lCount = 1
    
23.     k = UBound(arrResult, 2)
    
24.     For i = LBound(arr) + 1 To UBound(arr)
    
25.         strKey = arr(i, 1) & "#" & arr(i, 5) & "#" & arr(i, 6) & "#" & arr(i, 7) & "#" & arr(i, 8)
    
26.         If objDic.exists(strKey) Then
    
27.             lPos = objDic(strKey)
    
28.             arrResult(lPos, 9) = arrResult(lPos, 9) & " " & arr(i, 9)
    
29.             arrResult(lPos, 10) = arrResult(lPos, 10) + arr(i, 10)
    
30.         Else
    
31.             lCount = lCount + 1
    
32.             objDic.Add strKey, lCount
    
33.             lPos = lCount
    
34.             For j = LBound(arr, 2) To k
    
35.                 arrResult(lPos, j) = arr(i, j)
    
36.             Next
    
37.             If arrResult(lPos, 7) = arrResult(lPos - 1, 7) And arrResult(lPos, 6) = arrResult(lPos - 1, 6) And arrResult(lPos, 5) = arrResult(lPos - 1, 5) Then
    
38.                 arrResult(lPos, k) = ""
    
39.             End If
    
40.         End If
    
41.     Next
    
42. 
    
43.     'With Sheet2
    
44.     '.UsedRange.ClearContents
    
45.     '.Range("a1").Resize(lCount, k).Value = arrResult
    
46.     'end with
    
47.    
    
48.     Worksheets.Add
    
49.     Range("a1").Resize(lCount, k).Value = arrResult
    
50.    
    
51.     MsgBox "合并完成"
    
52.    
    
53. End Sub
    

复制代码

toylife

完美解决 谢谢烟花老师，不知道什么时候才有老师这样的技术

米莉沙

小老头慢慢消化学习