[已解决]品名相同且颜色相同的项目合并数量相加颜色合并在同一个单元格内

jiangjian138

品名相同且颜色相同的项目合并数量相加颜色合并在同一个单元格内
如果品名、单位相同，数量自动求和，然后颜色都合并在同一个单元格内、用顿号隔开
品名相同且颜色相同的项目合并数量相加颜色合并在同一个单元格内.zip (20.19 KB, 下载次数: 10)

2015-3-27 10:48 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

grf1973

2015-3-27 11:18

1. Sub tt()
   
2.     Range("a7:d65536").ClearContents
   
3.     Application.ScreenUpdating = False
   
4.     Dim d As Object, arr, i&, s&, w$
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     arr = Sheet1.Range("a6").CurrentRegion
   
7.     ReDim brr(1 To UBound(arr), 1 To 4)
   
8.     For i = 1 To UBound(arr)
   
9.         w = arr(i, 1) & "," & arr(i, 2)
   
10.         If Not d.exists(w) Then
    
11.            s = s + 1
    
12.            d(w) = s
    
13.            brr(s, 1) = arr(i, 1)
    
14.            brr(s, 2) = arr(i, 2)
    
15.            brr(s, 4) = arr(i, 4)
    
16.         End If
    
17.         p = d(w)
    
18.         brr(p, 3) = brr(p, 3) + arr(i, 3)
    
19.         If InStr(brr(p, 4), arr(i, 4)) = 0 Then brr(p, 4) = brr(p, 4) & "," & arr(i, 4)
    
20.     Next
    
21.     [a7].Resize(s, 4) = brr
    
22.     Application.ScreenUpdating = True
    
23. End Sub

复制代码

跳转到最佳答案楼层

grf1973

1. Sub tt()
   
2.     Range("a7:d65536").ClearContents
   
3.     Application.ScreenUpdating = False
   
4.     Dim d As Object, arr, i&, s&, w$
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     arr = Sheet1.Range("a6").CurrentRegion
   
7.     ReDim brr(1 To UBound(arr), 1 To 4)
   
8.     For i = 1 To UBound(arr)
   
9.         w = arr(i, 1) & "," & arr(i, 2)
   
10.         If Not d.exists(w) Then
    
11.            s = s + 1
    
12.            d(w) = s
    
13.            brr(s, 1) = arr(i, 1)
    
14.            brr(s, 2) = arr(i, 2)
    
15.            brr(s, 4) = arr(i, 4)
    
16.         End If
    
17.         p = d(w)
    
18.         brr(p, 3) = brr(p, 3) + arr(i, 3)
    
19.         If InStr(brr(p, 4), arr(i, 4)) = 0 Then brr(p, 4) = brr(p, 4) & "," & arr(i, 4)
    
20.     Next
    
21.     [a7].Resize(s, 4) = brr
    
22.     Application.ScreenUpdating = True
    
23. End Sub

复制代码

grf1973

请看附件。

26759761@qq.com

你之前的代码改的

1. Sub yy()
   
2. Range("a7:d65536").ClearContents
   
3. Dim d As Object, arr, i&, s&, w$, x, r, d1
   
4. Set d = CreateObject("scripting.dictionary")
   
5. Set d1 = CreateObject("scripting.dictionary")
   
6. arr = Sheet1.Range("a6:d" & Sheet1.Range("a65536").End(3).Row)
   
7. ReDim brr(1 To UBound(arr), 1 To 4)
   
8. For i = 1 To UBound(arr)
   
9.     w = arr(i, 1) & arr(i, 2)
   
10.     If d(w) = "" Then
    
11.        s = s + 1: d(w) = s
    
12.       For x = 1 To 4: brr(s, x) = arr(i, x): Next
    
13.       Else
    
14.       r = d(w)
    
15.       brr(r, 3) = brr(r, 3) + arr(i, 3)
    
16.         If InStr(brr(r, 4), arr(i, 4)) = 0 Then
    
17.            brr(r, 4) = brr(r, 4) & "," & arr(i, 4)
    
18.         End If
    
19.     End If
    
20. Next
    
21. [a7].Resize(s, 4) = brr
    
22. End Sub
    

复制代码