父子关系格式的BOM，转换为每成品料号展开一行或多行

nico1321

各位大侠，请求帮助，非常感谢！
原始数据有几万行，分别是所有料号的父阶/子阶关系，需要将数据整理成为成品料号的所有半成品料号子阶展开。
数据逻辑如下：

1.每个成品料号依次展开所有子阶

2. 同一层有多个子阶，则多行存放

3. 如某一成品料号展开过程中，有互为父子等异常状况，则备注该成品料号有“互为父子料号异常”

原始数据				程序运行结果
父阶料号属性	父阶料号	子阶料号		成品料号	备注	第一层子阶	第二层子阶	第三层子阶	第四层子阶	。。。。
成品料号	A	AA		A		AA	AAA	AAAA
半成品料号	AA	AAA		B		BB	BBB
半成品料号	AAA	AAAA		B		BB1	BBB1
成品料号	B	BB		C	互为父子异常	CC
半成品料号	B	BB1
半成品料号	BB	BBB
半成品料号	BB1	BBB1
成品料号	C	CC
半成品料号	CC	CC1
半成品料号	CC1	CC

dsmch

文件不能解压

nico1321

dsmch 发表于 2018-12-25 12:59
文件不能解压

不好意思，新增附件

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, j, k, a, b, cnt, m, n, s, t, dic
  Set dic = CreateObject("scripting.dictionary")
  arr = [a1].CurrentRegion.Offset(1)
  ReDim brr(1 To UBound(arr, 1), 1 To 10 + 2) '最多支持10级
  arr(UBound(arr, 1), 1) = "成品料号"
  ReDim crr(1 To 100) As String
  For i = 2 To UBound(arr, 1) - 1
    For j = i To UBound(arr, 1) - 1
      If arr(j + 1, 1) = "成品料号" Then
        t = arr(i, 2): cnt = 1
        For k = i + 1 To j
          If arr(k, 2) = arr(i, 2) Then cnt = cnt + 1
        Next
        For k = 1 To cnt
          For a = i To j
            If arr(a, 2) = t Then
              arr(a, 2) = vbNullString
              s = arr(a, 3)
              Call rec(arr, i, j, arr(a, 3), s)
              m = m + 1: n = 2
              brr(m, 1) = t: s = Split(s, ",")
              dic.RemoveAll
              For b = 0 To UBound(s)
                n = n + 1: brr(m, n) = s(b)
                dic(s(b)) = dic(s(b)) + 1
                If dic(s(b)) > 1 Then brr(m, 2) = "互为父子:" & s(b)
              Next
            End If
        Next a, k
        i = j: Exit For
      End If
  Next j, i
  With [e3]
    .Resize(Rows.Count - 2, UBound(brr, 2)).ClearContents
    .Resize(m, UBound(brr, 2)) = brr
  End With
End Sub

Function rec(arr, a, b, t, s)
  Dim i, j
  For i = a To b
    If arr(i, 2) = t Then
      s = s & "," & arr(i, 3)
      arr(i, 2) = vbNullString
      Call rec(arr, a, b, arr(i, 3), s)
    End If
  Next
End Function

nico1321

一把小刀闯天下 发表于 2018-12-25 15:14
Option Explicit

Sub test()

哇。。。。 超赞～～～  谢谢！

nico1321

一把小刀闯天下 发表于 2018-12-25 15:14
Option Explicit

Sub test()

还得请教一下，如果原始数据是随机存放的，可能前100行是成品，后1000行是半成品。。。
程序还需要怎样改动呢？ 谢谢！

一把小刀闯天下

nico1321 发表于 2018-12-25 16:09
还得请教一下，如果原始数据是随机存放的，可能前100行是成品，后1000行是半成品。。。
程序还需要怎样 ...

成品与半成品肯定有某种关系，否则无解。可以上附件图示一下，，，

nico1321

一把小刀闯天下 发表于 2018-12-25 16:10
成品与半成品肯定有某种关系，否则无解。可以上附件图示一下，，，

前2618行为成品料号，展开了一层，然后第二层，只得到了一个料号

dsmch

1. Dim d, s&
   
2. Sub 宏1()
   
3. arr = Range("a1").CurrentRegion
   
4. Set d = CreateObject("scripting.dictionary")
   
5. For i = 3 To UBound(arr)
   
6.     If Not d.exists(arr(i, 2)) Then
   
7.         d(arr(i, 2)) = arr(i, 3)
   
8.     Else
   
9.         d(arr(i, 2)) = d(arr(i, 2)) & "," & arr(i, 3)
   
10.     End If
    
11. Next
    
12. s = 0
    
13. For i = 3 To UBound(arr)
    
14.     If arr(i, 1) = "成品料号" Then aa arr(i, 2), "", s
    
15. Next
    
16. End Sub
    
17. Sub aa(x, p, s)
    
18. On Error GoTo 100
    
19. If d.exists(x) Then
    
20.     aa d(x), p & "-" & x, s
    
21. Else
    
22.     If InStr(x, ",") > 0 Then
    
23.         p2 = p
    
24.         y = Split(x, ",")
    
25.         For i = 0 To UBound(y)
    
26.             p = p2
    
27.             aa y(i), p, s
    
28.         Next
    
29.     Else
    
30. 100:        p = p & "-" & x
    
31.         s = s + 1
    
32.         Cells(s, "m") = Mid(p, 2)
    
33.     End If
    
34. End If
    
35. End Sub

复制代码

nico1321

dsmch 发表于 2018-12-25 20:05

神哪。。。运行出来了。。。  好激动～～～