Transforming 1level coded product tree to few level product tree

Hi there,

the solution I was trying was multiple vlookup function. But it seems quite complicated and still it requires a lot of effort and time. Oracle DB gives me an Excel file with all the products in one column and its parts in second column. It could seem that there is only one level bills of materials (BOMs), but actually our products could have many levels with many parts inside. So, Oracle DB has an unique ability to code (hide) information from me by giving just one level product tree. And what I need is to transform the data to normal BOM. I do not know if I expressed clearly, so I attach the Excel file from which you can have better view on my problem. Oracle product tree transformation.xlsx


I need a way to transform data to the table format I provide because later I could use pivot table.

Hi,

Attached is a VBA solution which should work in Excel 2003 and Excel 2007:

Option Explicit

Const sDataSheetNAME = "Sheet1"
Const sSeminalDataCELL = "A2"

Const sWorkingAreaFirstProductDataCOLUMN = "D"
Const sWorkingAreaFirstLevel1DataCOLUMN = "E"
Const sWorkingAreaFirstProductDataCELL = "D2"
Const sWorkingAreaFirstLevel1DataCELL = "E2"

Sub ClearProductTree()
  'This Clears the Destination Area (including Headers)

  Dim ws As Worksheet
  
  Dim iFirstColumnToClear As Long
  Dim iFirstRowToClear As Long
  Dim iLastColumn As Long
  Dim iLastRow As Long
   
  'Set the Worksheet object pointer
  'Select the sheet as the active sheet
  Set ws = Sheets(sDataSheetNAME)
  ws.Select

  'Find the last row and the last column of data
  iLastRow = Range("A1").SpecialCells(xlCellTypeLastCell).Row
  iLastColumn = Range("A1").SpecialCells(xlCellTypeLastCell).Column

  'Find the first and last rows to clear
  iFirstRowToClear = Range(sWorkingAreaFirstProductDataCELL).Row - 1   'Includes Header row
  iFirstColumnToClear = Range(sWorkingAreaFirstProductDataCELL).Column

  'Clear the destination area
  ws.Range(Cells(iFirstRowToClear, iFirstColumnToClear), Cells(iLastRow, iLastColumn)).Clear

End Sub


Sub CreateProductTree()
  'This Clears the 'Destination Area' then Creates a 'Product Tree'

  Dim ws As Worksheet
  Dim r As Range
  Dim rr As Range
  
  Dim myRGB_PaleGreen As Long
  
  Dim i As Long
  Dim iColumnOffset As Long
  Dim iLastColumn As Long
  Dim iLastRow As Long
  Dim iLevel As Long
  Dim iMatchCount As Long
  Dim iRowOffset As Long
  
  Dim bNeedMore As Boolean
  
  Dim sColumnRange As String
  Dim sSourceRange As String
  Dim sValue As String
  
  
  'Initialize RGB Color(s)
  myRGB_PaleGreen = RGB(204, 255, 204)
  
  'Set the Worksheet object pointer
  'Select the sheet as the active sheet
  Set ws = Sheets(sDataSheetNAME)
  ws.Select

  'Clear the destination area
  Call ClearProductTree
   
  'Turn Off Screen Updating to make the application run faster and to eliminate screen flicker
  Application.ScreenUpdating = False
  
   
  'Find the last row and the last column of data
  iLastRow = Range("A1").SpecialCells(xlCellTypeLastCell).Row
  iLastColumn = Range("A1").SpecialCells(xlCellTypeLastCell).Column

  'Copy the original data to the working area
  sSourceRange = "A2:B" & iLastRow
  ws.Range(sSourceRange).Copy ws.Range(sWorkingAreaFirstProductDataCELL)
  
  'Determine the offset between the original data and the new data
  iRowOffset = Range(sWorkingAreaFirstProductDataCELL).Row - Range(sSeminalDataCELL).Row
  iColumnOffset = Range(sWorkingAreaFirstProductDataCELL).Column - Range(sSeminalDataCELL).Column

  'Convert all data in the working range to text (prepend zzzz to numeric data)
  For Each r In Range(sSourceRange).Offset(iRowOffset, iColumnOffset)
    'Debug.Print r.Address(False, False)
    If IsNumeric(r.Value) Then
      r.Value = "zzzz" & r.Value
    End If
  Next r
  
  'Sort the data
  ws.Range(sSourceRange).Offset(iRowOffset, iColumnOffset).Sort _
    Key1:=Range(sWorkingAreaFirstProductDataCELL), Order1:=xlAscending, _
    Key2:=Range(sWorkingAreaFirstLevel1DataCELL), Order2:=xlAscending, _
    Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
    Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal, _
    DataOption2:=xlSortNormal
  
  'Remove leading 'zzzz' from the text
  For Each r In Range(sSourceRange).Offset(iRowOffset, iColumnOffset)
    If Left(r.Value, 4) = "zzzz" Then
      r.Value = Mid(r.Value, 5, 9999)
    End If
  Next r
  
  ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  'Search for items in Level 2 that are in Level 1
  'Create Level 3 data for those items
  ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  
  'Find the last row and the last column of data
  iLastRow = Range("A1").SpecialCells(xlCellTypeLastCell).Row
  iLastColumn = Range("A1").SpecialCells(xlCellTypeLastCell).Column

  'Set the range of the 'Level 1' data column
  'All subsequent levels offset one column to the right for each additional level
  sColumnRange = sWorkingAreaFirstLevel1DataCELL & ":" & sWorkingAreaFirstLevel1DataCOLUMN & iLastRow
  
  'Search the Level Columns one at a time starting with 'Level 1' (e.g. Range("E2:E22")
  'Stop when there are no items at the next (lower) level
  bNeedMore = True
  While bNeedMore
  
    'Increment the Level Number
    iLevel = iLevel + 1
  
    
    'Initialize the match count for this level
    iMatchCount = 0
    
    'Set the column offset (which column is to be processed)
    iColumnOffset = iLevel - 1
    
    'Search each cell in the Column for a matching entry in the 'Products' Column
    For Each r In Range(sColumnRange).Offset(0, iColumnOffset)
      sValue = Trim(r.Text)
      'Debug.Print r.Address(False, False) & "  " & sValue
    
      'Only process non-blank values
      If Len(sValue) > 0 Then
    
    
        'Find the value in the previous level range COLUMN starting at the first data cell in the COLUMN
        Set rr = Nothing
        Set rr = ws.Columns(sWorkingAreaFirstProductDataCOLUMN).Find(What:=sValue, _
                      After:=ws.Range(sWorkingAreaFirstProductDataCELL), _
                      LookIn:=xlValues, _
                      LookAt:=xlWhole, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlNext, _
                      MatchCase:=False, _
                      SearchFormat:=False)
                      
        'If a match was found:
        'a. Increment the match counter
        'b. Put the matching item in the 'Next (lower) level' column
        If Not rr Is Nothing Then
          'Debug.Print "----  " & r.Address(False, False) & "  " & sValue
          iMatchCount = iMatchCount + 1
          r.Offset(0, 1) = rr.Offset(0, 1)
        End If
      End If
    Next r
  
    If iMatchCount = 0 Then
      bNeedMore = False
    End If
    'Debug.Print "Level " & iLevel & "   Match count = " & iMatchCount
  Wend
  
  'Put In Headers in the Result Area (One row above the start of data)
  ws.Range(sWorkingAreaFirstProductDataCELL).Offset(-1, 0) = "Products"
  ws.Range(sWorkingAreaFirstProductDataCELL).Offset(-1, 0).Interior.Color = myRGB_PaleGreen
  
  'Center all the data in the column horizontally and vertically
  ws.Columns(sWorkingAreaFirstProductDataCOLUMN).HorizontalAlignment = xlCenter
  ws.Columns(sWorkingAreaFirstProductDataCOLUMN).VerticalAlignment = xlCenter
  
  For i = 1 To iLevel
    'Each additional level is offset one column to the right
    iColumnOffset = i - 1
    
    'Put In Headers in the Result Area (One row above the start of data)
    ws.Range(sWorkingAreaFirstLevel1DataCELL).Offset(-1, iColumnOffset) = "Level " & i
    ws.Range(sWorkingAreaFirstLevel1DataCELL).Offset(-1, iColumnOffset).Interior.Color = myRGB_PaleGreen
    
    'Center all the data in the column horizontally and vertically
    ws.Columns(sWorkingAreaFirstLevel1DataCOLUMN).Offset(0, iColumnOffset).HorizontalAlignment = xlCenter
    ws.Columns(sWorkingAreaFirstLevel1DataCOLUMN).Offset(0, iColumnOffset).VerticalAlignment = xlCenter
  Next i

  'Turn Screen Updating back on
  Application.ScreenUpdating = True

End Sub

If you choose to use JB's solution the following macro in an ordinary code module should allow JB's formula to work in Excel 2003. Coincidentally, the following code was created by JB several years ago. Thanks again JB.

'This module emulates the following functions not available in Excel 2003:
' IFERROR()
'
'
Function IFERROR(ToEvaluate As Variant, Default As Variant) As Variant
  'Duplicates Excel 2007 functionality (UDF)
  '
  'Courtesy of JBeaucaire post #5 of http://www.excelforum.com/excel-general/693584-iferror-for-2003-a.html
  If IsArray(ToEvaluate) Then
    IFERROR = IIf(IsError(ToEvaluate(1)), Default, ToEvaluate)
  Else
    IFERROR = IIf(IsError(ToEvaluate), Default, ToEvaluate)
  End If
End Function

Lewis

I've just now spotted solution. When I opened it I've just started to laugh out of joy. Incredible! LJMetzger is genius! THAN YOU VERY MUCH!