多级数据嵌套查找

狂飚的蜗牛

能想到可能用字典能解决，但没写出来。问题见附件，谢谢。
Book1.rar (9.54 KB, 下载次数: 13)

2017-11-27 13:16 上传

点击文件名下载附件

yjh_27

站内搜 BOM  底层材料

microyip

你提供的结果存在很多相同的，不知道你的正确还是我的正确了

liulang0808

1. Public arr
   
2. Public brr
   
3. Public a
   
4. Public str2
   
5. Sub 按钮1_Click()
   
6.     arr = Sheets("p").[a1].CurrentRegion
   
7.     brr = Sheets("z").[a1].CurrentRegion
   
8.     Set d = CreateObject("scripting.dictionary")
   
9.     a = 2
   
10.     With Sheets("提前code")
    
11.         For j = 2 To UBound(arr)
    
12.             If Left(arr(j, 2), 1) = "R" Then
    
13.                 Cells(a, 1) = arr(j, 1)
    
14.                 Cells(a, 2) = arr(j, 2)
    
15.                 a = a + 1
    
16.             Else
    
17.                 str2 = arr(j, 1)
    
18.                 mh arr(j, 2)
    
19. 
    
20.             End If
    
21.         Next j
    
22.     End With
    
23. End Sub
    
24. Sub mh(str1)
    
25.     For i = 2 To UBound(brr)
    
26.         If brr(i, 1) = str1 Then
    
27.             If Left(brr(i, 2), 1) = "R" Then
    
28.                 Cells(a, 1) = str2
    
29.                 Cells(a, 2) = brr(i, 2)
    
30.                 a = a + 1
    
31.             Else
    
32.                 mh brr(i, 2)
    
33.             End If
    
34.         End If
    
35.     Next i
    
36. End Sub
    

复制代码

liulang0808

附件内容供参考，结果与楼主的有出入
另外提取结果有重复项，如果需要去重，可以进一步处理

狂飚的蜗牛

感谢楼上两位回复，是要去重的，谢谢。

狂飚的蜗牛

microyip 发表于 2017-11-27 15:29
你提供的结果存在很多相同的，不知道你的正确还是我的正确了

依您的为准，谢谢。

microyip

狂飚的蜗牛 发表于 2017-11-28 11:12
依您的为准，谢谢。

我的很复杂，没4楼简单，主要是怕不停去增加的时候产生遗漏

1. Sub 父子查找()
   
2.     Dim vData As Variant, nRow As Double, oDic As Object, oData As Object
   
3.     Dim sItem As String, sRM As String, vItem As Variant, vRM As Variant, vTmpRM As Variant
   
4.    
   
5.     Set oDic = CreateObject("Scripting.Dictionary")
   
6.     Set oData = CreateObject("Scripting.Dictionary")
   
7.     vData = Sheet2.UsedRange.Value
   
8.     For nRow = 2 To UBound(vData)
   
9.         sItem = Trim(vData(nRow, 1))
   
10.         sRM = Trim(vData(nRow, 2))
    
11.         If sItem <> "" And sRM <> "" Then
    
12.             If UCase(sRM) Like "Z*" Then
    
13.                 If Not oData.Exists(sItem) Then Set oData(sItem) = CreateObject("Scripting.Dictionary")
    
14.                 oData(sItem)(sRM) = 0
    
15.             Else
    
16.                 If Not oDic.Exists(sItem) Then Set oDic(sItem) = CreateObject("Scripting.Dictionary")
    
17.                 oDic(sItem)(sRM) = 0
    
18.             End If
    
19.         End If
    
20.     Next
    
21.     For Each vItem In oData.Keys
    
22.         Do While oData(vItem).Count > 0
    
23.             vTmpRM = oData(vItem).Keys()(0)
    
24.             oData(vItem).Remove vTmpRM
    
25.             If oDic.Exists(vTmpRM) Then
    
26.                 For Each vRM In oDic(vTmpRM).Keys
    
27.                     oDic(vItem)(vRM) = 0
    
28.                 Next
    
29.                 If oData.Exists(vTmpRM) Then
    
30.                     For Each vRM In oData(vTmpRM).Keys
    
31.                         oData(vItem)(vRM) = 0
    
32.                     Next
    
33.                 End If
    
34.             Else '如果不存在如何处置
    
35.                 oDic(vItem)(vTmpRM) = 0
    
36.             End If
    
37.         Loop
    
38.         oData.Remove vItem
    
39.     Next
    
40.    
    
41.     oData.RemoveAll
    
42.     vData = Sheet1.UsedRange.Value
    
43.     For nRow = 2 To UBound(vData)
    
44.         sItem = Trim(vData(nRow, 1))
    
45.         sRM = Trim(vData(nRow, 2))
    
46.         If sItem <> "" And sRM <> "" Then
    
47.             If Not oData.Exists(sItem) Then Set oData(sItem) = CreateObject("Scripting.Dictionary")
    
48.             If UCase(sRM) Like "Z*" And oDic.Exists(sRM) Then
    
49.                 For Each vRM In oDic(sRM).Keys
    
50.                     oData(sItem)(vRM) = 0
    
51.                 Next
    
52.             Else
    
53.                 oData(sItem)(sRM) = 0
    
54.             End If
    
55.         End If
    
56.     Next
    
57.    
    
58.     vData = Empty
    
59.     ReDim vData(1 To 2, 1 To 1)
    
60.     nRow = 0
    
61.     For Each vItem In oData.Keys
    
62.         For Each vRM In oData(vItem).Keys
    
63.             nRow = nRow + 1
    
64.             ReDim Preserve vData(1 To 2, 1 To nRow)
    
65.             vData(1, nRow) = vItem
    
66.             vData(2, nRow) = vRM
    
67.         Next
    
68.     Next
    
69.     With Sheet3
    
70.         .[D:E].ClearContents
    
71.         If nRow > 0 Then [D2:E2].Resize(nRow) = Application.WorksheetFunction.Transpose(vData)
    
72.     End With
    
73. End Sub

复制代码

microyip

附上附件以供参考

liulang0808

1. Public arr
   
2. Public brr
   
3. Public a
   
4. Public str2
   
5. Public d
   
6. Sub 按钮1_Click()
   
7.     arr = Sheets("p").[a1].CurrentRegion
   
8.     brr = Sheets("z").[a1].CurrentRegion
   
9.     Set d = CreateObject("scripting.dictionary")
   
10.     With Sheets("提前code")
    
11.         For j = 2 To UBound(arr)
    
12.             If Left(arr(j, 2), 1) = "R" Then
    
13.                 d(arr(j, 1) & "#" & arr(j, 2)) = ""
    
14.             Else
    
15.                 str2 = arr(j, 1)
    
16.                 mh arr(j, 2)
    
17.             End If
    
18.         Next j
    
19.         .[a2].Resize(d.Count, 1) = WorksheetFunction.Transpose(d.keys)
    
20.         .[a2].Resize(18).TextToColumns Destination:=Range("A2"), DataType:=xlDelimited, _
    
21.         TextQualifier:=xlDoubleQuote, OtherChar:="#"
    
22.     End With
    
23.    
    
24. End Sub
    
25. Sub mh(str1)
    
26.     For i = 2 To UBound(brr)
    
27.         If brr(i, 1) = str1 Then
    
28.             If Left(brr(i, 2), 1) = "R" Then
    
29.                 d(str2 & "#" & brr(i, 2)) = ""
    
30.             Else
    
31.                 mh brr(i, 2)
    
32.             End If
    
33.         End If
    
34.     Next i
    
35. End Sub

复制代码