对应提取不重复项

往事随风5416

求助各路大侠大神，如附件所示，从“基础数据”表签中，对应提取不重复项到“提取结果”表签中，而且去除“0”项。附件为示意，实际的工作表数据会多很多，希望通过公式或VBA得到答案。
先拜谢了！
PS：此网站很棒，工作中我经常光顾搜索答案。这是我第一次发帖求助，实在是找不到对应的帖子来借鉴啊！

skyzxh

用字典法可以完成。。。。。。。。。。。

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("基础数据")
   
7.     r = .Cells(.Rows.Count, 2).End(xlUp).Row
   
8.     arr = .Range("a2:c" & r)
   
9.   End With
   
10.   For i = 1 To UBound(arr)
    
11.     If Len(arr(i, 1)) <> 0 Then
    
12.       pm = arr(i, 1)
    
13.     End If
    
14.     If arr(i, 2) <> 0 Then
    
15.       If Not d.exists(pm) Then
    
16.         Set d(pm) = CreateObject("scripting.dictionary")
    
17.       End If
    
18.       If Not d(pm).exists(arr(i, 2)) Then
    
19.         Set d(pm)(arr(i, 2)) = CreateObject("scripting.dictionary")
    
20.       End If
    
21.       d(pm)(arr(i, 2))(arr(i, 3)) = ""
    
22.     End If
    
23.   Next
    
24.   With Worksheets("提取结果")
    
25.     .Cells.Clear
    
26.     m = 2
    
27.     s = 0
    
28.     For Each aa In d.keys
    
29.       m0 = m
    
30.       For Each bb In d(aa).keys
    
31.         .Cells(m, 2) = bb
    
32.         .Cells(m, 3).Resize(1, d(aa)(bb).Count) = d(aa)(bb).keys
    
33.         If s < d(aa)(bb).Count Then
    
34.           s = d(aa)(bb).Count
    
35.         End If
    
36.         m = m + 1
    
37.       Next
    
38.       With .Cells(m0, 1)
    
39.         .Value = aa
    
40.         .Resize(m - m0, 1).Merge
    
41.       End With
    
42.     Next
    
43.     .Range("a1:c1") = Array("品名", "品牌", "型号")
    
44.     .Range("c1").Resize(1, s).Merge
    
45.     With .Range("a1").Resize(m - 1, 2 + s)
    
46.       .Borders.LineStyle = xlContinuous
    
47.       .HorizontalAlignment = xlCenter
    
48.       .VerticalAlignment = xlCenter
    
49.     End With
    
50.   End With
    
51.         
    
52. End Sub
    

复制代码

chxw68

欢迎新会员！

everbest2015

Sub 提取不重复数据()
    Dim ar, br, d As Object, i&, s$, sr$, r&, t, tt, m&, j&, n&
    r = Sheet1.Cells(Rows.Count, "B").End(xlUp).Row
    If r > 1 Then
        ar = Sheet1.Cells(1, 1).Resize(r, 3)
        Set d = CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(ar)
            If ar(i, 1) <> "" Then s = ar(i, 1)
            If ar(i, 2) <> 0 Then sr = s & "☆" & ar(i, 2)
            If Not d.exists(sr) Then
                Set d(sr) = CreateObject("Scripting.Dictionary")
            End If
            If ar(i, 3) <> 0 Then d(sr)(ar(i, 3)) = ""
        Next
    Else
        Exit Sub
    End If
  r = Sheet2.Cells(Rows.Count, 2).End(xlUp).Row
  If r > 1 Then
      br = Sheet2.Range("a1").Resize(r, UBound(ar))
      m = 2
      For i = 2 To UBound(br)
            If br(i, 1) <> "" Then s = br(i, 1)
            If br(i, 2) <> 0 Then sr = s & "☆" & br(i, 2)
            If d.exists(sr) Then
                    tt = d(sr).keys
                    For Each t In tt
                        m = m + 1
                        br(i, m) = t
                    If j < m Then j = m + 2
                    Next
                    m = 2
            End If
      Next
      Stop
      Sheet2.Range("a1").Resize(r, j) = br
      Set d = Nothing
    Else
        End
  End If
End Sub

everbest2015

感觉我的应该是有点小问题,在j处那个地方，

往事随风5416

三、四楼的朋友，不愧是侠圣，非常感谢！已完美解决！！
再请教侠圣，“按钮1”这个东东，可以重命名吗？他和表签的命名、不同模块的代码相关的吗？因为我另外试了一下，表签名称变了，直接把这个东东复制过去是没有用的（高手莫笑，俺是菜鸟乜）
另外请教，如何给你送花啊？刚刚我本来写好了很多如上的文字，中间想到送花，点击鲜花上面的数字后，回头一看，白写了啊
还有，可以加你好友吗？
最后，也感谢五、六楼的朋友，我试过，好像是有些问题。不过也很感谢你的热心相助！

往事随风5416

我刚刚试了下，这个按钮，是可以重命名，并指定宏的。哈哈哈，真是开心啊！

jiminyanyan

往事随风5416 发表于 2019-3-17 11:13
三、四楼的朋友，不愧是侠圣，非常感谢！已完美解决！！
再请教侠圣，“按钮1”这个东东，可以重命名吗？ ...

花这种虚拟的东西，送不送没多大关系拉（新人送不了）。