【求助】急！母件与子件对应关系（批量一对多查找）

StriveDandy

兄弟们，急！。。具体放附件里面了！！应该描述的挺详细的，外面就简单介绍一下

说明
1.母件料号前2位是16的，为成品，我已经筛选出来了
2.A:B列是数据源，母件和子件的对应关系
3.如何批量整理出母件和子件的关系
4.目前我认为，里面牵扯到一对多查询，以及一对多之后如何自动将单元格往下移等问题。。（目前这是我的思路，不知道大神们有什么其他思路）



万分感谢！！！！！！！！！！！！！！！

wodewan

Option Explicit
Dim d_other As Object
Sub test()
Dim arr, brr, ar, crr(1 To 50000, 1 To 10)
Dim i&, j&, m&, x
Dim d_main As Object
Set d_other = CreateObject("scripting.dictionary")
Set d_main = CreateObject("scripting.dictionary")
arr = ActiveSheet.Range("a1").CurrentRegion
For i = 2 To UBound(arr)
    If Val(Left(arr(i, 1), 2)) = 16 Then
        If Not d_main.exists(arr(i, 1)) Then
            d_main(arr(i, 1)) = Array(arr(i, 2))
        Else
            ar = d_main(arr(i, 1))
            ReDim Preserve ar(UBound(ar) + 1)
            ar(UBound(ar)) = arr(i, 2)
            d_main(arr(i, 1)) = ar
        End If
    Else
        If Not d_other.exists(arr(i, 1)) Then
            d_other(arr(i, 1)) = Array(arr(i, 2))
        Else
            ar = d_other(arr(i, 1))
            ReDim Preserve ar(UBound(ar) + 1)
            ar(UBound(ar)) = arr(i, 2)
            d_other(arr(i, 1)) = ar
        End If
    End If
Next

For Each x In d_main.keys
    m = m + 1: crr(m, 1) = x
    brr = d_main(x)
    For i = LBound(brr) To UBound(brr)
        x = brr(i)
        Call DG(x, crr, d_other, m, 2)
    Next
Next
With ActiveSheet
    .Range("s2:zz" & Rows.Count).ClearContents
    .Range("s2").Resize(m, UBound(crr, 2)).NumberFormat = "@"
    .Range("s2").Resize(m, UBound(crr, 2)) = crr
End With
End Sub

Sub DG(x, crr, d_other, m, n)
Dim i, k, brr
        crr(m, n) = x
        If Not d_other.exists(x) Then
            m = m + 1
        Else
            brr = d_other(x)
            For i = LBound(brr) To UBound(brr)
                Call DG(brr(i), crr, d_other, m, n + 1)
            Next
        End If
End Sub

yjh_27

自定义函数 见
BOM 大纲排序-自定义函数
http://club.excelhome.net/thread-1175717-1-1.html
(出处: ExcelHome技术论坛)

StriveDandy

yjh_27 发表于 2020-3-29 14:56
自定义函数 见
BOM 大纲排序-自定义函数
http://club.excelhome.net/thread-1175717-1-1.html

好的，谢谢

StriveDandy

yjh_27 发表于 2020-3-29 14:56
自定义函数 见
BOM 大纲排序-自定义函数
http://club.excelhome.net/thread-1175717-1-1.html

老师，您好！看了您的东西我突然多了个灵感，能不能把D:F列，变成G:I列这样呢。。(我把红色部分列在G:I列)。。。这样的话就知道母件下面对应的子件了，也比较清晰

yjh_27

StriveDandy 发表于 2020-3-29 18:24
老师，您好！看了您的东西我突然多了个灵感，能不能把D:F列，变成G:I列这样呢。。(我把红色部分列在G:I列 ...

要求独特。可以实现，重新下载3L附件。

StriveDandy

yjh_27 发表于 2020-3-29 21:24
要求独特。可以实现，重新下载3L附件。

老师，我把完整的数据放进去，想多输出几个值，我尝试进行了一些修改，但是好像有点不对额。请问对应输出的值的增加是在哪增加的呢，具体放附件了

yjh_27

StriveDandy 发表于 2020-3-30 17:21
老师，我把完整的数据放进去，想多输出几个值，我尝试进行了一些修改，但是好像有点不对额。请问对应输出 ...

1. Sub aa()
   
2. r = Worksheets("DataBase").Range("a" & Rows.Count).End(xlUp).Row
   
3. arr = Worksheets("DataBase").Range("a2:t" & r)
   
4. brr = BOMSort(arr, 1, 14, -21, , , , 1)
   
5. For i = 1 To UBound(brr)
   
6.     If Left(brr(i, 1), 2) = "16" Then Exit For
   
7. Next
   
8. clm = Array(, 1, 2, 14, 15, 18, 19, 20, 21)
   
9. ReDim crr(1 To UBound(brr) - i + 1, 1 To UBound(clm))
   
10. For i = i To UBound(brr)
    
11.     ci = ci + 1
    
12.     For j = 1 To UBound(clm)
    
13.         crr(ci, j) = brr(i, clm(j))
    
14. Next j, i
    
15. r1 = Worksheets("Sheet1").Range("a" & Rows.Count).End(xlUp).Row
    
16. Worksheets("Sheet1").Range("a2").Resize(r1 - 1, UBound(crr, 2)).ClearContents
    
17. Worksheets("Sheet1").Range("a2").Resize(UBound(crr), UBound(crr, 2)).NumberFormatLocal = "@"
    
18. Worksheets("Sheet1").Range("a2").Resize(UBound(crr), UBound(crr, 2)) = crr
    
19. End Sub

复制代码

StriveDandy

yjh_27 发表于 2020-3-30 20:04

老师您好，实在不好意思，我是要cc变成这样哦，我用你这个改了一下。。没有改出来

yjh_27

StriveDandy 发表于 2020-3-31 11:06
老师您好，实在不好意思，我是要cc变成这样哦，我用你这个改了一下。。没有改出来

1. Sub dd()
   
2. r = Worksheets("DataBase").Range("a" & Rows.Count).End(xlUp).Row
   
3. arr = Worksheets("DataBase").Range("a2:t" & r)
   
4. brr = BOMSort(arr, 1, 14, -21, 2, , , 1)
   
5. For i = 1 To UBound(brr)
   
6.     If Left(brr(i, 1), 2) = "16" Then Exit For
   
7. Next
   
8. clm = Array(, 1, 2, 14, 15, 18, 19, 20, 21)
   
9. ReDim crr(1 To UBound(brr) - i + 1, 1 To UBound(clm))
   
10. For i = i To UBound(brr)
    
11.     ci = ci + 1
    
12.     For j = 1 To UBound(clm)
    
13.         crr(ci, j) = brr(i, clm(j))
    
14.     Next
    
15.     If crr(ci, 8) = 2 Then i0 = ci Else crr(ci, 1) = crr(i0, 1): crr(ci, 2) = crr(i0, 2)
    
16. Next
    
17. r1 = Worksheets("Sheet1").Range("a" & Rows.Count).End(xlUp).Row
    
18. Worksheets("Sheet1").Range("a2").Resize(r1 - 1, UBound(crr, 2)).ClearContents
    
19. Worksheets("Sheet1").Range("a2").Resize(UBound(crr), UBound(crr, 2)).NumberFormatLocal = "@"
    
20. Worksheets("Sheet1").Range("a2").Resize(UBound(crr), UBound(crr, 2)) = crr
    
21. End Sub
    

复制代码