[已解决]如何将把不同的品名合并起来？？

dinosaur27111

求大神帮忙啊~~
票号存在相同的，要先得到不同的票号，再根据票号去找到对应的品名（品名也有相同的，也需要得到不同的品名），然后将所有不同的品名用“/”连起来，放在一个单元格里；另一个单元格计算出同票号里，有几不同品名的产品

最佳答案

月排行榜 / 总排行榜

苏子龙

2017-8-16 16:59

1. Sub tt()
   
2. Dim arr, brr, i%, j%, n%, d
   
3.     arr = Range("a1:d11")
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     ReDim brr(1 To UBound(arr), 1 To 3)
   
6.     For i = 2 To UBound(arr)
   
7.         If Not d.exists(arr(i, 1)) Then
   
8.             n = n + 1
   
9.             d(arr(i, 1)) = ""
   
10.             brr(n, 1) = arr(i, 1)
    
11.             Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    
12.         End If
    
13.         For j = 2 To UBound(arr, 2)
    
14.             If Not d(arr(i, 1)).exists(arr(i, j)) And InStr(arr(i, j), "空白") = 0 Then
    
15.                 brr(n, 2) =IIf(brr(n, 3), brr(n, 2) & "/" & arr(i, j), arr(i, j)): brr(n, 3) = brr(n, 3) + 1
    
16.                 d(arr(i, 1))(arr(i, j)) = ""
    
17.             End If
    
18.         Next
    
19.     Next
    
20.     [a20].Resize(n, 3) = brr
    
21. End Sub

复制代码

跳转到最佳答案楼层

windyjw007

模拟结果有误吧！{:2312:}

1. Sub test()
   
2.     Dim d As Object
   
3.     Dim ar, br(1 To 100000, 1 To 3)
   
4.     Dim sr As String
   
5.     Dim i As Long, j As Long, k As Long
   
6.     Dim x, y
   
7.     Set d = CreateObject("scripting.dictionary")
   
8.     ar = Cells(1, 1).CurrentRegion
   
9.     k = 1: br(1, 1) = "票号": br(1, 2) = "品名": br(1, 3) = "同票号内有几个产品"
   
10.     For i = 2 To UBound(ar)
    
11.         If Not d.exists(ar(i, 1)) Then
    
12.             k = k + 1
    
13.             br(k, 1) = ar(i, 1)
    
14.             Set d(ar(i, 1)) = CreateObject("scripting.dictionary")
    
15.         End If
    
16.         For j = 2 To UBound(ar, 2)
    
17.             If ar(i, j) = "(空白)" Then
    
18.                 Exit For
    
19.             Else
    
20.                 If Not d(ar(i, 1)).exists(ar(i, j)) Then
    
21.                     d(ar(i, 1)).Add ar(i, j), ""
    
22.                 End If
    
23.             End If
    
24.         Next j
    
25.     Next i
    
26.     x = d.keys
    
27.     For i = 1 To d.Count
    
28.         If d(x(i - 1)).Count > 0 Then
    
29.             y = d(x(i - 1)).keys
    
30.             For j = 1 To d(x(i - 1)).Count
    
31.                 sr = sr & "/" & y(j - 1)
    
32.             Next j
    
33.             br(i + 1, 2) = Mid(sr, 2)
    
34.             br(i + 1, 3) = j - 1
    
35.             sr = ""
    
36.         Else
    
37.             br(i + 1, 3) = 0
    
38.         End If
    
39.     Next i
    
40.     With Cells(1, 7)
    
41.         .Resize(Rows.Count, 3).ClearContents
    
42.         .Resize(k, 3) = br
    
43.     End With
    
44. End Sub
    

复制代码

grf1973

1. Sub grf1()
   
2.     arr = Range("a1:d11")
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     ReDim brr(1 To UBound(arr), 1 To 3)
   
5.     For i = 2 To UBound(arr)
   
6.         x = arr(i, 1)
   
7.         If Not d.exists(x) Then
   
8.             n = n + 1: d(x) = n
   
9.             brr(n, 1) = x
   
10.         End If
    
11.         p = d(x)
    
12.         For j = 2 To UBound(arr, 2)
    
13.             If InStr(brr(p, 2), arr(i, j)) = 0 And Not arr(i, j) Like "*空白*" Then
    
14.                 brr(p, 2) = IIf(brr(p, 2) = "", arr(i, j), brr(p, 2) & "/" & arr(i, j))
    
15.                 brr(p, 3) = brr(p, 3) + 1
    
16.             End If
    
17.         Next
    
18.     Next
    
19.     [a20].Resize(n, 3) = brr
    
20. End Sub
    

复制代码

grf1973

之前想了个sql的法子，结果还是要结合数组字典，作个参考吧。

苏子龙

1. Sub tt()
   
2. Dim arr, brr, i%, j%, n%, d
   
3.     arr = Range("a1:d11")
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     ReDim brr(1 To UBound(arr), 1 To 3)
   
6.     For i = 2 To UBound(arr)
   
7.         If Not d.exists(arr(i, 1)) Then
   
8.             n = n + 1
   
9.             d(arr(i, 1)) = ""
   
10.             brr(n, 1) = arr(i, 1)
    
11.             Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    
12.         End If
    
13.         For j = 2 To UBound(arr, 2)
    
14.             If Not d(arr(i, 1)).exists(arr(i, j)) And InStr(arr(i, j), "空白") = 0 Then
    
15.                 brr(n, 2) =IIf(brr(n, 3), brr(n, 2) & "/" & arr(i, j), arr(i, j)): brr(n, 3) = brr(n, 3) + 1
    
16.                 d(arr(i, 1))(arr(i, j)) = ""
    
17.             End If
    
18.         Next
    
19.     Next
    
20.     [a20].Resize(n, 3) = brr
    
21. End Sub

复制代码

dinosaur27111

谢谢各位，谢谢windyjw007，不过个人能力有限看太看懂你的；也谢谢grf1973，还是看得我头大；最后勉强把苏子龙的看懂了~~真是太感谢大家了