Recursive reverse BOM or Implosion

Like this?

	A	B	C	D	E	F	G
1	Qty	Component	Parent	Parent2	Parent3	Parent4	Parent5
2	1	520/00011/20	520/00000/00	520/00000/MG	520/00000/PS
3	1	520/33000/00	520/00000/00	520/00000/MG	520/00000/PS
4	1	520/33010/00	520/00000/00	520/00000/MG	520/00000/PS
5	1	520/42801/00	520/00000/00	520/00000/MG	520/00000/PS
6	1	056/00000/00	520/00000/00	520/00000/MG	520/00000/PS
7	1	520/00000/20	520/00000/00	520/00000/MG	520/00000/PS
8	1	520/00000/00IQ	520/00000/00IQOQ
9	1	520/00000/00OQ	520/00000/00IQOQ
10	1	520/42870/03	520/00000/00IQOQ
11	1	004/60074/08	520/00000/20	520/00000/00	520/00000/MG	520/00000/PS
12	1	004/60074/09	520/00000/20	520/00000/00	520/00000/MG	520/00000/PS
13	1	520/20800/99	520/00000/20	520/00000/00	520/00000/MG	520/00000/PS
14	1	520/34000/00	520/00000/20	520/00000/00	520/00000/MG	520/00000/PS
15	1	004/60074/08	520/00000/20X
16	1	004/60074/09	520/00000/20X
17	1	004/60074/17	520/00000/20X

The formula in D2 is =IF(C2 = "", "", IFERROR(VLOOKUP(C2, B$2:C$4644, 2, FALSE), ""))

So if you find 004/28136/00 in the components column, ...

	A	B	C	D	E	F	G	H	I	J	K
1	Qty	Component	Parent	Parent2	Parent3	Parent4	Parent5	Parent6	Parent7	Parent8	Parent9
2285	2	004/28136/00	520/34007/04	520/34007/01	520/34007/00

... which agrees with your list as far as it goes. Not what you're looking for?

I'm sure whatever it it could be implemented in VBA, but I can't visualize what you're looking for.

Maya a small, complete example (20 lines or so) with inputs and desired output?

Missed that, but now that I see it, I don't understand it. Why is it disjoint, with col K blank?

What information does it usefully convey?

Slow on the uptake, apparently.

If you filter for a given component, doesn't this tell you all the affected higher-level assemblies?

	A	B	C	D	E	F	G	H
1	Qty	Component	Parent1	Parent2	Parent3	Parent4	Parent5	Parent6
2285	2	004/28136/00	520/34007/04	520/34007/01	520/34007/00
2286	2	004/28136/00	520/34057/04	520/34057/00	520/33610/00	520/00000/SSRA	520/00000/PS

I think the penny just dropped; it's a one-to-many relationship at all levels of the hierarchy.

Hove to ponder what is an appropriate data structure.

Option Explicit
Private Sub QS(ByRef v1, iL As Long, iH As Long)
  Dim pvt As String, tmp As String, tL As Long, tH  As Long
  tL = iL: tH = iH: pvt = v1((iL + iH) \ 2, 1)
  While tL <= tH
    While v1(tL, 1) < pvt And tL < iH: tL = tL + 1: Wend
    While pvt < v1(tH, 1) And tH > iL: tH = tH - 1: Wend
    If (tL <= tH) Then
       tmp = v1(tL, 1): v1(tL, 1) = v1(tH, 1): v1(tH, 1) = tmp
       tmp = v1(tL, 2): v1(tL, 2) = v1(tH, 2): v1(tH, 2) = tmp
       tL = tL + 1: tH = tH - 1
    End If
  Wend
  If iL < tH Then QS v1, iL, tH
  If tL < iH Then QS v1, tL, iH
End Sub
Public Sub Test2()
  Const prefixSheetName As String = "MyResults_"
  Dim a() As String, b, c() As Long, e As Long, i As Long, j As Long, k As Long, pRow As Long, pCol As Long, maxRow As Long, maxCol As Long, rng As Range, sht As Worksheet, strToSearch As String, v1, v2, z1 As New Collection, z2 As New Collection
  Debug.Print Format$(Now, "HH:MM:SS")
  With Sheets("bom")
    Set rng = .Range("A1").CurrentRegion.Offset(1).Resize(, 2)
    Set rng = rng.Resize(rng.Rows.Count - 1)
    strToSearch = .Range("E2").Value
  End With
  ReDim a(1 To rng.Rows.Count, 1 To 2)
  For j = 1 To 2
      b = rng.Columns(j).Value
      For i = 1 To UBound(b, 1)
          a(i, j) = b(i, 1)
      Next i
  Next j
  ReDim b(1 To UBound(a, 1))
  For i = 1 To UBound(a, 1)
      On Error Resume Next
         z1.Add key:=a(i, 2), Item:=i
      On Error GoTo 0
      j = z1(a(i, 2))
      If Len(b(j)) = 0 Then b(j) = i Else b(j) = b(j) & "," & i
  Next i
  If Len(strToSearch) Then
     On Error Resume Next
        i = z1(strToSearch)
        If Err.Number = 5 Then MsgBox "Item " & strToSearch & " is not found !": Exit Sub
     On Error GoTo 0
     z2.Add key:=strToSearch, Item:=i
  Else
     For Each v1 In z1
         z2.Add key:=a(v1, 2), Item:=v1
     Next v1
  End If
  For i = 1 To UBound(b)
      If Len(b(i)) Then
         v1 = Split(b(i), ",")
         ReDim c(1 To UBound(v1) + 1)
         For j = 1 To UBound(c)
             c(j) = CLng(v1(j - 1))
         Next j
         For j = 1 To UBound(c)
             For k = j + 1 To UBound(c)
                 If a(c(k), 1) < a(c(j), 1) Then e = c(j): c(j) = c(k): c(k) = e
             Next k
         Next j
         b(i) = c
         On Error Resume Next
            For j = 1 To UBound(c)
                z2.Remove a(c(j), 1)
            Next j
         On Error GoTo 0
      End If
  Next i
  ReDim v1(1 To z2.Count, 1 To 2)
  i = 0
  For Each v2 In z2
      i = i + 1
      v1(i, 1) = a(v2, 2)
      v1(i, 2) = v2
  Next v2
  Set z2 = Nothing
  QS v1, 1, UBound(v1, 1)
  For i = 1 To UBound(v1, 1)
      z2.Add Array(v1(i, 2), 1)
  Next i
  Debug.Print Format$(Now, "HH:MM:SS")
  Application.ScreenUpdating = False
    maxRow = Sheets(1).Rows.Count   '10
    maxCol = Sheets(1).Columns.Count
    Application.DisplayAlerts = False
      For Each sht In Worksheets
          If Left$(sht.Name, Len(prefixSheetName)) = prefixSheetName Then sht.Delete
      Next sht
    Application.DisplayAlerts = True
    Set sht = Sheets.Add(after:=Sheets(Sheets.Count))
    sht.Name = prefixSheetName & "1"
    pRow = 0
    Do
       v1 = z2(1)
       z2.Remove 1
       pRow = pRow + 1
       pCol = v1(1)
       If pCol > maxCol Then MsgBox "Not enough columns to display": Exit Sub
       If pRow > maxRow Then
          i = CLng(Split(sht.Name, "_")(1)) + 1
          Set sht = Sheets.Add(after:=Sheets(Sheets.Count))
          sht.Name = prefixSheetName & i
          pRow = 1
       End If
       If pCol = 1 Then
          sht.Cells(pRow, pCol) = a(v1(0), 2)
          v2 = b(v1(0))
       Else
          sht.Cells(pRow, pCol) = a(v1(0), 1)
          v2 = Empty
          On Error Resume Next
             v2 = b(z1(a(v1(0), 1)))
          On Error GoTo 0
       End If
       If IsArray(v2) Then
          For i = UBound(v2) To 1 Step -1
              If z2.Count Then
                 z2.Add Item:=Array(v2(i), pCol + 1), before:=1
              Else
                 z2.Add Item:=Array(v2(i), pCol + 1)
              End If
          Next i
       End If
    Loop Until z2.Count = 0
  Application.ScreenUpdating = True
  Debug.Print Format$(Now, "HH:MM:SS") & vbCrLf
End Sub

You are welcome, micro62w.

I have modified the code, so it will be more "resources friendly" (like RAM usage etc), please test it on your big file to see if there is some improvement.

As per your request, now the code will search the value of cell bom!E2 (Sheet "bom" at cell E2) :
- If this cell is empty, then the code will search for all items
- If this cell is not empty, but the code cannot find any parent that match this cell's value, a messagebox will popped up as a warning, and the macro will stop
- If this cell is not empty and the code can find a parent with this cell's value, then query is performed for this parent only

Private Sub QS(ByRef a, ByRef c, iL As Long, iH As Long)
  Dim pvt As String, tmp As Long, tL As Long, tH  As Long
  tL = iL: tH = iH: pvt = a((iL + iH) \ 2, 2)
  While (tL <= tH)
    While (a(c(tL), 2) < pvt And tL < iH): tL = tL + 1: Wend
    While (pvt < a(c(tH), 2) And tH > iL): tH = tH - 1: Wend
    If (tL <= tH) Then
       tmp = c(tL): c(tL) = c(tH): c(tH) = tmp: tL = tL + 1: tH = tH - 1
    End If
  Wend
  If (iL < tH) Then QS a, c, iL, tH
  If (tL < iH) Then QS a, c, tL, iH
End Sub
Public Sub Test2()
  Dim a() As String, b, c() As Long, e As Long, i As Long, j As Long, k As Long, pRow As Long, pCol As Long, maxRow As Long, maxCol As Long, rng As Range, strToSearch As String, v1, v2, z1 As New Collection, z2 As New Collection
  Debug.Print Format$(Now, "HH:MM:SS")
  With Sheets("bom")
    Set rng = .Range("A1").CurrentRegion.Offset(1).Resize(, 2)
    Set rng = rng.Resize(rng.Rows.Count - 1)
    strToSearch = .Range("E2").Value
  End With
  ReDim a(1 To rng.Rows.Count, 1 To 2)
  For j = 1 To 2
      b = rng.Columns(j).Value
      For i = 1 To UBound(b, 1)
          a(i, j) = b(i, 1)
      Next i
  Next j
  ReDim b(1 To UBound(a, 1))
  For i = 1 To UBound(a, 1)
      On Error Resume Next
         z1.Add key:=a(i, 2), Item:=i
      On Error GoTo 0
      j = z1(a(i, 2))
      If Len(b(j)) = 0 Then b(j) = i Else b(j) = b(j) & "," & i
  Next i
  If Len(strToSearch) Then
     On Error Resume Next
        i = z1(strToSearch)
        If Err.Number = 5 Then MsgBox "Item " & strToSearch & " is not found !": Exit Sub
     On Error GoTo 0
     z2.Add key:=strToSearch, Item:=i
  Else
     For Each v1 In z1
         z2.Add key:=a(v1, 2), Item:=v1
     Next v1
  End If
  For i = 1 To UBound(b)
      If Len(b(i)) Then
         v1 = Split(b(i), ",")
         ReDim c(1 To UBound(v1) + 1)
         For j = 1 To UBound(c)
             c(j) = CLng(v1(j - 1))
         Next j
         For j = 1 To UBound(c)
             For k = j + 1 To UBound(c)
                 If a(c(k), 1) < a(c(j), 1) Then e = c(j): c(j) = c(k): c(k) = e
             Next k
         Next j
         b(i) = c
         On Error Resume Next
            For j = 1 To UBound(c)
                z2.Remove a(c(j), 1)
            Next j
         On Error GoTo 0
      End If
  Next i
  ReDim c(1 To z2.Count)
  i = 0
  For Each v1 In z2
      i = i + 1
      c(i) = v1
  Next v1
  QS a, c, 1, UBound(c)
  Set z2 = Nothing
  For i = 1 To UBound(c, 1)
      z2.Add Array(c(i), 1)
  Next i
  Erase c
  Application.ScreenUpdating = False
    On Error Resume Next
       i = Sheets("MyResults").Index
       If Err.Number = 9 Then Sheets.Add(after:=Sheets(Sheets.Count)).Name = "MyResults"
    On Error GoTo 0
    With Sheets("MyResults")
      .Cells.ClearContents
      maxRow = .Rows.Count
      maxCol = .Columns.Count
      pRow = 1
      Do
         v1 = z2(1)
         z2.Remove 1
         pRow = pRow + 1
         pCol = v1(1)
         If pRow > maxRow Or pCol > maxCol Then MsgBox "Not enough cells to display": Exit Sub
         If pCol = 1 Then
            .Cells(pRow, pCol) = a(v1(0), 2)
            v2 = b(v1(0))
         Else
            .Cells(pRow, pCol) = a(v1(0), 1)
            v2 = Empty
            On Error Resume Next
               v2 = b(z1(a(v1(0), 1)))
            On Error GoTo 0
         End If
         If IsArray(v2) Then
            For i = UBound(v2) To 1 Step -1
                If z2.Count Then
                   z2.Add Item:=Array(v2(i), pCol + 1), before:=1
                Else
                   z2.Add Item:=Array(v2(i), pCol + 1)
                End If
            Next i
         End If
      Loop Until z2.Count = 0
    End With
  Application.ScreenUpdating = True
  Debug.Print Format$(Now, "HH:MM:SS")
End Sub

kd, re your PM,

My formula doesn't solve the problem. It was one I created to make a tabular org chart starting from a two column list of {employee, supervisor}, and it assumed by definition that each child has exactly one parent, other than the top dog, who has none.

	C	D	E	F	G	H	I	J	K
2	ID	Spon ID	Spon ID	Spon ID	Spon ID	Spon ID	Spon ID	Spon ID	Spon ID
3	050180
4	050226	050180
5	052322	050226	050180
6	053075	050226	050180
7	071009	050226	050180
8	081168	071009	050226	050180
9	117995	081168	071009	050226	050180
10	323848	117995	081168	071009	050226	050180
11	323991	117995	081168	071009	050226	050180
12	130637	081168	071009	050226	050180
13	326896	130637	081168	071009	050226	050180
14	340248	130637	081168	071009	050226	050180
15	401300	340248	130637	081168	071009	050226	050180

That's not the case here, when any given assembly ("child", down to the component level) can be used in multiple higher-level assemblies ("parent"). I did not read your code closely, but this kind of data structure

z1.Add key:=a(i, 2), Item:=Array(a(i, 2), New Collection)

... was what I was trying to get my brain moving toward.

Nice work.

shg,

Thanks. Still I don't believe there is someone can think about this just using formulas




micro62w,

>>> I get an "out of stack space (error 28)" statement
Oops, that is easy to spot (based on the error code), I made a mistake in the quicksort routine.
I have updated my code on post #14, please try it again.

>>> The result may stretch beyond excels limits
On the updated code on post #14, I change the code so the output will come in several seperated sheets.
So for example if the output take 2,097,160 rows, the output will be displayed in these sheets :
- MyResults_1 (1,048,576 rows)
- MyResults_2 (1,048,576 rows)
- MyResults_3 (8 rows)

As for testing purpose, if using your file on post #1, and :
- change the value of cell bom!E2 to 004/28136/00
- edit this line of code :

maxRow = Sheets(1).Rows.Count

to

maxRow = 10

The macro will produce 4 sheets (MyResults_1 to MyResults_4)


>>> Can the code be carried over the "access" ?
Maybe, but I am not familiar with "Access", and I can imagine it will be extremely painfully very slow, since the process is performed based on file, not based on memory.
And beside, even if this could be done, how will you display the result then ?
But I guess using my edited code above (the output is seperated into several sheets), it will suite your need ?


>>> Additionally, I am wondering to carry the quantity and or u_m columns along do I continue to add to the existing code or is it best to supplement the results afterward.
If the problems above have been solved, then we can continue to this your next request (but not before solved).
If so, then upload your workbook with desired layout result.

One more thing, I need to know your Excel version (32 bit or 64 bit), and the amount of RAM on your PC (the code will be made based on this).

You are welcome.

I have included what I would be ...

Where is it ?



This is the explanation :

Read data from sheet bom :

  With Sheets("bom")
    Set rng = .Range("A1").CurrentRegion.Offset(1).Resize(, 2)
    Set rng = rng.Resize(rng.Rows.Count - 1)
    strToSearch = .Range("E2").Value
  End With

Since I thought the memory usage is tight in this case, so I convert the variant array (where each item of its member take 16 bytes, excluding the string itself) to string array (each member only take 4 bytes). I read column by column (column A then column B) to variant array b, which then using looping, writing to string array a. We can save about 900k x 2 columns x (16 - 4 bytes) = 21,600,000 bytes, or about 20 MB of RAM this way.

  ReDim a(1 To rng.Rows.Count, 1 To 2)
  For j = 1 To 2
      b = rng.Columns(j).Value
      For i = 1 To UBound(b, 1)
          a(i, j) = b(i, 1)
      Next i
  Next j

Next step is, for each unique parent item in column B, we will write down the row number where itself and it's duplicates occurred.
For get the unique parent items, we will use Excel's collection object (z1 in this case), and since the collection cannot change its data directly, we will use array b to store the collection's data.
For example, take item 520/00011/20, this item are listed in these rows : row 1, row 48, row 223 (we exclude the header so row 2 in the cell is row 1 in array, row 49 in in cell is row 48 in array etc). So the value of array b(1) is "1,48,223" where all of item 520/00011/20 is occurred. In other word, array b will be act as a holder of children list.

  ReDim b(1 To UBound(a, 1))
  For i = 1 To UBound(a, 1)
      On Error Resume Next
         z1.Add key:=a(i, 2), Item:=i
      On Error GoTo 0
      j = z1(a(i, 2))
      If Len(b(j)) = 0 Then b(j) = i Else b(j) = b(j) & "," & i
  Next i

Now, we need to get all the topmost parent items (a node that has no parent, or the "Top Dog" as shg said).
If the value of cell bom!E2 is not empty, then we only search for this parent item only, otherwise all parent items is calculated.
We add these topmost parent items to second collection (z2). This z2 will act as a "joblist" that should be calculated.
When you said "Recursive reverse BOM or Implosion", you are right, this kind of job must be performed using recursive method, but I will use collection object as a holder of a stack in this case, so the recursive can be avoided.

  If Len(strToSearch) Then             '--> cell bom!E2 is not empty, which means we will try to calculate only for this specific parent
     On Error Resume Next
        i = z1(strToSearch)
        If Err.Number = 5 Then MsgBox "Item " & strToSearch & " is not found !": Exit Sub  '--> If this parent is not found, then end macro immediately
     On Error GoTo 0
     z2.Add key:=strToSearch, Item:=i  '--> this parent item is found, so add it to the z2 collection
  Else
     For Each v1 In z1                 '--> since cell bom!E2 is empty, we will calculate all the "Top Dogs", so add everything from z1 (unique parents in column B) to z2  
         z2.Add key:=a(v1, 2), Item:=v1
     Next v1
  End If

As we know that at current state, the value of array b is a string (for example above, it is like "1,48,223"). Now we will convert/split this string into individual array member.

  For i = 1 To UBound(b)
      If Len(b(i)) Then
         v1 = Split(b(i), ",")
         ReDim c(1 To UBound(v1) + 1)
         For j = 1 To UBound(c)
             c(j) = CLng(v1(j - 1))
         Next j

We also want the array is sorted, for example if the value are 520/34017/01 and 520/34007/01, we will sort them into 520/34007/01 520/34017/01

         For j = 1 To UBound(c)
             For k = j + 1 To UBound(c)
                 If a(c(k), 1) < a(c(j), 1) Then e = c(j): c(j) = c(k): c(k) = e
             Next k
         Next j

We write back the array (from the splitted string) into array b (so array b now is converted from a string array to a jagged array of Long):

         b(i) = c

As the code above, we put the unique parent items of column B into collection z2 by these lines :

     For Each v1 In z1
         z2.Add key:=a(v1, 2), Item:=v1
     Next v1

but these items are not really the most "Top Dog" items. For example on cell bom!B3077 (520/34007/04), if we look cell bom!A3108, this "parent" has another parent (003/21064/00), so this is not an actual "Top Dog", we must delete this from collection z2, by using this code :

         On Error Resume Next
            For j = 1 To UBound(c)
                z2.Remove a(c(j), 1)
            Next j
         On Error GoTo 0
      End If
  Next i

Now we already have the "Top Dogs", but these "Top Dogs" are not sorted yet (remember, you have another sort routine above, but that is for the "children", not for the Top Dogs).
Since you have big data (900k), we will use the fastest sort routine : QuickSort. In the next lines, we prepare the Quicksort by writing collection z2 to array v1, then sort it, then read back to collection z2.

  ReDim v1(1 To z2.Count, 1 To 2)  '--> Write collection to array v1
  i = 0
  For Each v2 In z2
      i = i + 1
      v1(i, 1) = a(v2, 2)
      v1(i, 2) = v2
  Next v2
  Set z2 = Nothing
  QS v1, 1, UBound(v1, 1)          '--> QuickSort
  For i = 1 To UBound(v1, 1)       '--> Write back the "already sorted array" v1 to collection z2
      z2.Add Array(v1(i, 2), 1)
  Next i

At this point, all the preparations is completed, and we ready the actual writing to the cell.

  Debug.Print Format$(Now, "HH:MM:SS")

Some preparations (delete old output sheets if they are exists, create a new one, etc :

 Application.ScreenUpdating = False
    maxRow = Sheets(1).Rows.Count
    maxCol = Sheets(1).Columns.Count
    Application.DisplayAlerts = False
      For Each sht In Worksheets
          If Left$(sht.Name, Len(prefixSheetName)) = prefixSheetName Then sht.Delete
      Next sht
    Application.DisplayAlerts = True
    Set sht = Sheets.Add(after:=Sheets(Sheets.Count))
    sht.Name = prefixSheetName & "1"
    pRow = 0

Now we do the "recursive", the job is listed on collection z2, we will proceed one by one the items of z2, everytime an item has been processed, we delete this item from the collection z2, so if there is no more item remained on z2 (z2.count = 0), it means all the job has been calculated and we can exit the Do..Loop.

    Do
       v1 = z2(1)             'Retrieve first item (job) from collection z2
       z2.Remove 1            'Since it has been saved to variable v1, we can remove it from the collection (so the next remaining item will become the next first item in the next loop)
       pRow = pRow + 1        'Increment pRow (pRow is a variable that point at what row the data will be written)
       pCol = v1(1)           'Get pCol (pCol is a variable that point at what column the data will be written)
       If pCol > maxCol Then MsgBox "Not enough columns to display": Exit Sub  'If pCol is greater than the maximum number of columns that Excel has, then write a MessageBox and quit
       If pRow > maxRow Then  'If pRow is exceeding the maximum number of rows that Excel has, then create a new sheet and all next jobs will be performed on this new sheet     
          i = CLng(Split(sht.Name, "_")(1)) + 1
          Set sht = Sheets.Add(after:=Sheets(Sheets.Count))
          sht.Name = prefixSheetName & i
          pRow = 1
       End If

       If pCol = 1 Then       'Write data to cell
          sht.Cells(pRow, pCol) = a(v1(0), 2)
          v2 = b(v1(0))
       Else
          sht.Cells(pRow, pCol) = a(v1(0), 1)
          v2 = Empty
          On Error Resume Next
             v2 = b(z1(a(v1(0), 1)))
          On Error GoTo 0
       End If

       If IsArray(v2) Then   'If this item has a child, we will "recurse" into the childs, by pushing/adding all the childs to the collection z2
          For i = UBound(v2) To 1 Step -1
              If z2.Count Then
                 z2.Add Item:=Array(v2(i), pCol + 1), before:=1
              Else
                 z2.Add Item:=Array(v2(i), pCol + 1)
              End If
          Next i
       End If
    Loop Until z2.Count = 0
  Application.ScreenUpdating = True
  Debug.Print Format$(Now, "HH:MM:SS") & vbCrLf

How do you calculate sheet Result1 column M (qty from bom) ?

For example, take cell Result1!C4 (the item is 520/34007/01).

If you AutoFilter sheet bom column A with this item (520/34007/01), Excel will return :

520/34007/01	003/20403/00	1	EA
520/34007/01	003/48080/00	11	EA
520/34007/01	004/16235/00	3	EA
520/34007/01	004/28133/00	7	EA
520/34007/01	004/28553/00	4	EA
520/34007/01	004/28781/01	18	EA
520/34007/01	004/28895/00	2	EA
520/34007/01	004/28956/01	4	EA
520/34007/01	004/32627/00	19	IN
520/34007/01	520/17607/011	1	EA
520/34007/01	520/34007/02	1	EA
520/34007/01	520/34007/03	1	EA
520/34007/01	520/34007/04	1	EA
520/34007/01	520/34805/16	1	EA

If you sum column C of this filtered range, the sum is 74, but on your manual calculation on cell Result1!M4, it is written 1

Also note that the unit is not always the same, for example for the filtered range above, you got one item with "IN" unit while the others is in "EA" unit.

Below is the code as your request :
- Sub Test3_Layout1 will create output as sample layout in your sheet Result1
- Sub Test3_Layout2 will create output as sample layout in your sheet Result2

Option Explicit
Private Sub QS(ByRef v1, iL As Long, iH As Long)
  Dim pvt As String, tmp As String, tL As Long, tH  As Long
  tL = iL: tH = iH: pvt = v1((iL + iH) \ 2, 1)
  While tL <= tH
    While v1(tL, 1) < pvt And tL < iH: tL = tL + 1: Wend
    While pvt < v1(tH, 1) And tH > iL: tH = tH - 1: Wend
    If (tL <= tH) Then
       tmp = v1(tL, 1): v1(tL, 1) = v1(tH, 1): v1(tH, 1) = tmp
       tmp = v1(tL, 2): v1(tL, 2) = v1(tH, 2): v1(tH, 2) = tmp
       tL = tL + 1: tH = tH - 1
    End If
  Wend
  If iL < tH Then QS v1, iL, tH
  If tL < iH Then QS v1, tL, iH
End Sub
Public Sub Test3_Layout1()
  Const prefixSheetName As String = "MyResults_"
  Dim a() As String, b1() As Variant, b2() As Long, b3() As String, c() As Long, e As Long, i As Long, j As Long, k As Long, pRow As Long, pCol As Long, pColRightTable As Long, maxRow As Long, maxCol As Long, u As Long, rng As Range, sht As Worksheet, strToSearch As String, v1, v2, v3, z1 As New Collection, z2 As New Collection
  Debug.Print Format$(Now, "HH:MM:SS")
  pColRightTable = Sheets(1).Columns.Count \ 2 + 1
  With Sheets("bom")
    Set rng = .Range("A1").CurrentRegion.Offset(1).Resize(, 3)
    Set rng = rng.Resize(rng.Rows.Count - 1)
    strToSearch = .Range("E2").Value
  End With
  ReDim a(1 To rng.Rows.Count, 1 To 2)
  For j = 1 To 2
      v1 = rng.Columns(j).Value
      For i = 1 To UBound(v1, 1)
          a(i, j) = v1(i, 1)
      Next i
  Next j
  ReDim b1(1 To UBound(a, 1))
  ReDim b2(1 To UBound(a, 1))
  v1 = rng.Columns(3).Value
  For i = 1 To UBound(b2)
      b2(i) = v1(i, 1)
  Next i
  For i = 1 To UBound(a, 1)
      On Error Resume Next
         z1.Add key:=a(i, 2), Item:=i
      On Error GoTo 0
      j = z1(a(i, 2))
      If Len(b1(j)) = 0 Then b1(j) = i Else b1(j) = b1(j) & "," & i
  Next i
  u = z1.Count
  For i = 1 To UBound(a, 1)
      On Error Resume Next
         z1.Add key:=a(i, 1), Item:=-i
      On Error GoTo 0
      j = Abs(z1(a(i, 1)))
  Next i
  ReDim b3(1 To UBound(a, 1), 1 To 2)
  v1 = Sheets("item").Range("A1").CurrentRegion.Value
  For i = 2 To UBound(v1, 1)
      On Error Resume Next
         j = Abs(z1(v1(i, 1)))
         If Err.Number = 0 Then b3(j, 1) = v1(i, 2) & "|" & v1(i, 3)
      On Error GoTo 0
  Next i
  v1 = Sheets("order").Range("A1").CurrentRegion.Value
  For i = 2 To UBound(v1, 1)
      On Error Resume Next
         j = Abs(z1(v1(i, 1)))
         If Err.Number = 0 Then
            If Len(b3(j, 2)) = 0 Then b3(j, 2) = v1(i, 4)
            b3(j, 2) = b3(j, 2) & "|" & v1(i, 2) & "|" & v1(i, 3)
         End If
      On Error GoTo 0
  Next i
  If Len(strToSearch) Then
     On Error Resume Next
        i = z1(strToSearch)
        If Err.Number = 5 Then MsgBox "Item " & strToSearch & " is not found !": Exit Sub
     On Error GoTo 0
     z2.Add key:=strToSearch, Item:=i
  Else
     i = 0
     For Each v1 In z1
         i = i + 1
         If i > u Then Exit For
         z2.Add key:=a(v1, 2), Item:=v1
     Next v1
  End If
  For i = 1 To UBound(b1)
      If Len(b1(i)) Then
         v1 = Split(b1(i), ",")
         ReDim c(1 To UBound(v1) + 1)
         For j = 1 To UBound(c)
             c(j) = v1(j - 1)
         Next j
         For j = 1 To UBound(c)
             For k = j + 1 To UBound(c)
                 If a(c(k), 1) < a(c(j), 1) Then e = c(j): c(j) = c(k): c(k) = e
             Next k
         Next j
         b1(i) = c
         On Error Resume Next
            For j = 1 To UBound(c)
                z2.Remove a(c(j), 1)
            Next j
         On Error GoTo 0
      End If
  Next i
  ReDim v1(1 To z2.Count, 1 To 2)
  i = 0
  For Each v2 In z2
      i = i + 1
      v1(i, 1) = a(v2, 2)
      v1(i, 2) = v2
  Next v2
  Set z2 = Nothing
  QS v1, 1, UBound(v1, 1)
  For i = 1 To UBound(v1, 1)
      z2.Add Array(v1(i, 2), 1)
  Next i
  Debug.Print Format$(Now, "HH:MM:SS")
  Application.ScreenUpdating = False
    maxRow = Sheets(1).Rows.Count   '10
    Application.DisplayAlerts = False
      For Each sht In Worksheets
          If Left$(sht.Name, Len(prefixSheetName)) = prefixSheetName Then sht.Delete
      Next sht
    Application.DisplayAlerts = True
    Set sht = Sheets.Add(after:=Sheets(Sheets.Count))
    sht.Name = prefixSheetName & "1"
    pRow = 1
    Do
       v1 = z2(1)
       z2.Remove 1
       pRow = pRow + 1
       pCol = v1(1)
       If maxCol < pCol Then maxCol = pCol
       If pCol = pColRightTable Then MsgBox "Location of second table is not right enough, please change (raise) the value of pColRightTable !": Exit Sub
       If pRow > maxRow Then
          i = CLng(Split(sht.Name, "_")(1)) + 1
          Set sht = Sheets.Add(after:=Sheets(Sheets.Count))
          sht.Name = prefixSheetName & i
          pRow = 1
       End If
       With sht.Rows(pRow)
         If pCol = 1 Then
            .Cells(pCol) = a(v1(0), 2)
            .Cells(pCol + 1).Resize(, 2) = Split(b3(v1(0), 1), "|")
            v3 = Split("" & "|" & b3(v1(0), 2), "|")
            .Cells(pColRightTable).Resize(, UBound(v3) + 1) = v3
            v2 = b1(v1(0))
         Else
            .Cells(pCol) = a(v1(0), 1)
            v2 = Empty
            On Error Resume Next
               i = z1(a(v1(0), 1))
               v2 = b1(i)
            On Error GoTo 0
            i = Abs(i)
            .Cells(pCol + 1).Resize(, 2) = Split(b3(i, 1), "|")
            v3 = Split(v1(2) & "|" & b3(i, 2), "|")
            .Cells(pColRightTable).Resize(, UBound(v3) + 1) = v3
         End If
       End With
       If IsArray(v2) Then
          For i = UBound(v2) To 1 Step -1
              If z2.Count Then
                 z2.Add Item:=Array(v2(i), pCol + 1, b2(v2(i))), before:=1
              Else
                 z2.Add Item:=Array(v2(i), pCol + 1, b2(v2(i)))
              End If
          Next i
       End If
    Loop Until z2.Count = 0
    maxCol = maxCol + 2
    Application.DisplayAlerts = False
      For Each sht In Worksheets
          If Left$(sht.Name, Len(prefixSheetName)) = prefixSheetName Then Range(sht.Columns(maxCol + 2), sht.Columns(pColRightTable - 1)).Delete xlShiftToLeft
      Next sht
    Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  Debug.Print Format$(Now, "HH:MM:SS") & vbCrLf
End Sub
Public Sub Test3_Layout2()
  Const prefixSheetName As String = "MyResults_"
  Dim a() As String, b1() As Variant, b2() As Long, b3() As String, c() As Long, e As Long, i As Long, j As Long, k As Long, pRow As Long, pCol As Long, pColRightTable As Long, maxRow As Long, maxCol As Long, u As Long, rng As Range, sht As Worksheet, strToSearch As String, v1, v2, v3, z1 As New Collection, z2 As New Collection
  Debug.Print Format$(Now, "HH:MM:SS")
  pColRightTable = Sheets(1).Columns.Count \ 2 + 1
  With Sheets("bom")
    Set rng = .Range("A1").CurrentRegion.Offset(1).Resize(, 3)
    Set rng = rng.Resize(rng.Rows.Count - 1)
    strToSearch = .Range("E2").Value
  End With
  ReDim a(1 To rng.Rows.Count, 1 To 2)
  For j = 1 To 2
      v1 = rng.Columns(j).Value
      For i = 1 To UBound(v1, 1)
          a(i, j) = v1(i, 1)
      Next i
  Next j
  ReDim b1(1 To UBound(a, 1))
  ReDim b2(1 To UBound(a, 1))
  v1 = rng.Columns(3).Value
  For i = 1 To UBound(b2)
      b2(i) = v1(i, 1)
  Next i
  For i = 1 To UBound(a, 1)
      On Error Resume Next
         z1.Add key:=a(i, 2), Item:=i
      On Error GoTo 0
      j = z1(a(i, 2))
      If Len(b1(j)) = 0 Then b1(j) = i Else b1(j) = b1(j) & "," & i
  Next i
  u = z1.Count
  For i = 1 To UBound(a, 1)
      On Error Resume Next
         z1.Add key:=a(i, 1), Item:=-i
      On Error GoTo 0
      j = Abs(z1(a(i, 1)))
  Next i
  ReDim b3(1 To UBound(a, 1), 1 To 2)
  v1 = Sheets("item").Range("A1").CurrentRegion.Value
  For i = 2 To UBound(v1, 1)
      On Error Resume Next
         j = Abs(z1(v1(i, 1)))
         If Err.Number = 0 Then b3(j, 1) = v1(i, 2) & "|" & v1(i, 3)
      On Error GoTo 0
  Next i
  v1 = Sheets("order").Range("A1").CurrentRegion.Value
  For i = 2 To UBound(v1, 1)
      On Error Resume Next
         j = Abs(z1(v1(i, 1)))
         If Err.Number = 0 Then
            If Len(b3(j, 2)) = 0 Then b3(j, 2) = v1(i, 4)
            b3(j, 2) = b3(j, 2) & "|" & v1(i, 2) & "|" & v1(i, 3)
         End If
      On Error GoTo 0
  Next i
  If Len(strToSearch) Then
     On Error Resume Next
        i = z1(strToSearch)
        If Err.Number = 5 Then MsgBox "Item " & strToSearch & " is not found !": Exit Sub
     On Error GoTo 0
     z2.Add key:=strToSearch, Item:=i
  Else
     i = 0
     For Each v1 In z1
         i = i + 1
         If i > u Then Exit For
         z2.Add key:=a(v1, 2), Item:=v1
     Next v1
  End If
  For i = 1 To UBound(b1)
      If Len(b1(i)) Then
         v1 = Split(b1(i), ",")
         ReDim c(1 To UBound(v1) + 1)
         For j = 1 To UBound(c)
             c(j) = v1(j - 1)
         Next j
         For j = 1 To UBound(c)
             For k = j + 1 To UBound(c)
                 If a(c(k), 1) < a(c(j), 1) Then e = c(j): c(j) = c(k): c(k) = e
             Next k
         Next j
         b1(i) = c
         On Error Resume Next
            For j = 1 To UBound(c)
                z2.Remove a(c(j), 1)
            Next j
         On Error GoTo 0
      End If
  Next i
  ReDim v1(1 To z2.Count, 1 To 2)
  i = 0
  For Each v2 In z2
      i = i + 1
      v1(i, 1) = a(v2, 2)
      v1(i, 2) = v2
  Next v2
  Set z2 = Nothing
  QS v1, 1, UBound(v1, 1)
  For i = 1 To UBound(v1, 1)
      z2.Add Array(v1(i, 2), 1, 1)
  Next i
  Debug.Print Format$(Now, "HH:MM:SS")
  Application.ScreenUpdating = False
    maxRow = Sheets(1).Rows.Count   '10
    Application.DisplayAlerts = False
      For Each sht In Worksheets
          If Left$(sht.Name, Len(prefixSheetName)) = prefixSheetName Then sht.Delete
      Next sht
    Application.DisplayAlerts = True
    Set sht = Sheets.Add(after:=Sheets(Sheets.Count))
    sht.Name = prefixSheetName & "1"
    pRow = 1
    Do
       v1 = z2(1)
       z2.Remove 1
       pRow = pRow + 1
       pCol = v1(1)
       If maxCol < pCol Then maxCol = pCol
       If pCol = pColRightTable Then MsgBox "Location of second table is not right enough, please change (raise) the value of pColRightTable !": Exit Sub
       If pRow > maxRow Then
          i = CLng(Split(sht.Name, "_")(1)) + 1
          Set sht = Sheets.Add(after:=Sheets(Sheets.Count))
          sht.Name = prefixSheetName & i
          pRow = 1
       End If
       With sht.Rows(pRow)
         If pCol = 1 Then
            .Cells(pCol) = v1(2)
            v3 = Split("" & "|" & a(v1(0), 2) & "|" & b3(v1(0), 1) & "|" & b3(v1(0), 2), "|")
            .Cells(pColRightTable).Resize(, UBound(v3) + 1) = v3
            v2 = b1(v1(0))
         Else
            .Cells(pCol) = v1(2)
            v2 = Empty
            On Error Resume Next
               i = z1(a(v1(0), 1))
               v2 = b1(i)
            On Error GoTo 0
            i = Abs(i)
            v3 = Split(v1(3) & "|" & a(v1(0), 1) & "|" & b3(i, 1) & "|" & b3(i, 2), "|")
            .Cells(pColRightTable).Resize(, UBound(v3) + 1) = v3
         End If
       End With
       If IsArray(v2) Then
          For i = UBound(v2) To 1 Step -1
              If z2.Count Then
                 z2.Add Item:=Array(v2(i), pCol + 1, i, b2(v2(i))), before:=1
              Else
                 z2.Add Item:=Array(v2(i), pCol + 1, i, b2(v2(i)))
              End If
          Next i
       End If
    Loop Until z2.Count = 0
    Application.DisplayAlerts = False
      For Each sht In Worksheets
          If Left$(sht.Name, Len(prefixSheetName)) = prefixSheetName Then Range(sht.Columns(maxCol + 1), sht.Columns(pColRightTable - 1)).Delete xlShiftToLeft
      Next sht
    Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  Debug.Print Format$(Now, "HH:MM:SS") & vbCrLf
End Sub

You are welcome.

Don't forget to mark this thread as solved :
select Thread Tools from the menu link above and mark this thread as SOLVED.

Regards