Locate unique Parents in denormalized parent/child table - vba

[Drew]

Hello All,
What I'm trying to accomplish is finding the first unique parent in a de-normalized table (left to right view).

For example, take the following table parent/child table:

Cost Center -Leaf	CENTER_DESC	LEVEL_01	LEVEL_02	LEVEL_03	LEVEL_04	LEVEL_05	LEVEL_06	LEVEL_07	LEVEL_08
1234567	cc1	$	$J	$JA	$JAB	$JABC	$JABCC	$JABCCA	1234567
2222222	cc2	$	$J	$JA	$JAB	$JABC	$JABCD	$JABCDA	2222222
4444444	cc3	$	$D	$DA	$DAA	$DAAB	4444444	4444444	4444444
7654321	cc4	$	$D	$DA	$DAB	7654321	7654321	7654321	7654321

I've used recursive queries but only used on a normalized table so I can't get my head around how to approach this? If using a recursive query to start the procedure is the best way, I just can't figure out how to fill based on the de-normalized view then weed it down to the result I need. Overall goal: I have to lookup a leaf id value (1st col) in the above table then figure out what level to apply a parent node at a unique level... the rows can vary up to 25k and the levels can go up to 11. Say I was looking up 2222222, then the code would have to traverse through all 'like' parents until it becomes unique... so, in this case 2222222 and 1234567 have the same parent in level_01, level_02, level_03, level_04 and level_05 but differ at level_06 which is the result I'm looking for - looking up cost center 2222222 would result in $JABCD. Likewise, if I was looking up 7654321, then code would have to traverse through 'like' parents... in this case 4444444 has have the same parent in level_01, level_02 and level_03 but differ at level_04 which is the result I'm after - looking up cost center 7654321 would result in $DAB. Now, to even make it worse... there are instances where a cost center is unique (no other siblings in the hierarchy) so I would just want to see the result at Level_03. Thanks, Drew

 

[Biz]

Hi,

Just wondering how do you invoke your code. Please give me an example as I don't understand how to utilize the code provided above.

Biz

 

[MoshiM]

It's a function that returns a Collection that optionally takes input as a single value or a 1-Dimensional array or a 2D array consisting of either a single column or row . So something like

Sub Example()

Dim Example_CLCTN As Collection

set Example_CLCTN =Drew_Hierarchy'returns collection for all values in column 1 on the active sheet
'or
Set Example_CLCTN =Drew_Hierarchy array(a,b,c,d)'returns collection for just these values........a,b,c,d must appear in column 1 or no value will be added to collection
'or
set Example_CLCTN =Drew_Hierarchy a    'same note as above

'Retrieving values from Collection
112=Example_ClCTN(key) 'where key is a value in Column 1 converted to a string  like cstr(112) if it isn't one already.

End Sub

Also I messaged Drew about a small addition that needed to be made for dealing with array inputs (I accidentally deleted it) so I'll add the amended code here.

Public Function Drew_Hierarchy(Optional ByVal Cost_Center As Variant) As Collection

Dim K As Long, Z As Long, NthLevel As Long, _
Main_CLCTN As New Collection, Output As New Collection, _
InputD() As Variant, Sub_R() As Variant, Comparison_Array() As Variant

Dim Total_Levels As Long, Column_1_Key As String, Min_Loop As Long, Max_Loop As Long, _
ARI() As Variant, Allow_Comparison As Boolean, Max_Level As Long

Total_Levels = 11

InputD = ActiveSheet.UsedRange.Value2

ReDim Sub_R(1 To UBound(InputD, 2))

If Not IsMissing(Cost_Center) Then 'Convert input to an array if it isn't already
                            
    If IsArray(Cost_Center) Then 'If input is already an array then
                                 'Deterimine number of dimensions
        ARI=Cost_Center
    
        On Error Resume Next

        Do
            K = K + 1
            Z = LBound(ARI, K)
        Loop Until Err.Number <> 0

        K = K - 1
  
        On Error GoTo 0

        Select Case True 'Do certain things for the number of dimensions present in the array
      
            Case K = 1
      
            Case K >= 2
      
                 If (UBound(ARI, 1) > 1 And UBound(ARI, 2) > 1 And K = 2) Or K > 2 Then 'if more than 2 rows of data then display message
          
                     MsgBox "Array inputs must be either a single row or column. Exiting Function Drew_Hierarchy."
          
                     Exit Function
              
                ElseIf UBound(ARI, 1) = 1 Or UBound(ARI, 2) = 1 Then 'if eiter 1 row or 1 column
          
                    With Application
              
                        If UBound(ARI, 2) = 1 Then 'if only a single column
                  
                            ARI = .Transpose(ARI)
                      
                        ElseIf UBound(ARI, 1) = 1 Then 'transpose twice to get a 1D array
                  
                            ARI = .Transpose(.Transpose(ARI))
                      
                        End If
              
                    End With
              
                End If
          
        End Select

    Else

        ARI = Array(Cost_Center)

    End If

End If

With Main_CLCTN

    For K = 2 To UBound(InputD, 1)      'Skip headers in first row of used range and loop rows

        For Z = 1 To UBound(InputD, 2)  'Splice current row of array into another array
            Sub_R(Z) = InputD(K, Z)
        Next Z

        .Add Sub_R, CStr(Sub_R(1)) 'Place spliced array into collection and key with what is in column 1 of data on worksheet

    Next K

    If Not IsMissing(Cost_Center) Then
        Min_Loop = LBound(ARI)
        Max_Loop = UBound(ARI)
    Else
        Min_Loop = 1
        Max_Loop = .Count
    End If

    For Z = Min_Loop To Max_Loop

        If Not IsMissing(Cost_Center) Then 'If function is supplied with arguements then
                                           'only collection items that match those keys will be used for Comparison_Array
            On Error GoTo Key_Unknown
    
            Comparison_Array = .ITEM(CStr(ARI(Z)))
    
            On Error GoTo 0
    
        Else                             'Otherwise all arrays within Main_CLCTN will eventually be used for Comparison_Array

            Comparison_Array = .ITEM(Z)
    
        End If

        Column_1_Key = CStr(Comparison_Array(1)) 'Key is whatever is in Column 1 of data range

        Max_Level = 0
    
        For K = 1 To .Count
    
            If Not IsMissing(Cost_Center) Then 'This conditional block ensures that the Comparison array isn't compared to itself
          
                If Main_CLCTN(K)(1) <> ARI(Z) Then Allow_Comparison = True
          
            ElseIf K <> Z Then
      
                Allow_Comparison = True
          
            End If
    
            If Allow_Comparison = True Then
    
                Sub_R = .ITEM(K)
        
                For NthLevel = 3 To Total_Levels + 2 'Loop levels 1 through total levels.... offset by 2 since levels start in column 3
            
                    If NthLevel = Total_Levels + 2 And Sub_R(NthLevel) = Comparison_Array(NthLevel) Then
              
                        Max_Level = 0 'return 3rd Level . The above conditional is executed if there's a non-unique hierarchy
                        GoTo Exit_K_Loop
                  
                    ElseIf Sub_R(NthLevel) <> Comparison_Array(NthLevel) Then 'If Level Hierarchies in both the Comparison_Array and the current array
                                                                          'from Main_CLCTN are different
                        If NthLevel > Max_Level Then Max_Level = NthLevel 'then update max_level if it's greater than recorded
                
                        Exit For 'Compare next array within Main_ClCtN to Comparison Array
                
                    End If
            
                Next NthLevel
        
                Allow_Comparison = False
        
            End If

        Next K
  
Exit_K_Loop:

        If Max_Level = 0 Then Max_Level = 5 'return 3rd Level if unique or non-unique hierarchy

        Output.Add Comparison_Array(Max_Level), Column_1_Key

Next_Loop_Z:

    Next Z

End With

Set Drew_Hierarchy = Output

Exit Function

Key_Unknown:

    Output.Add "Cost Center unavailable : " & ARI(Z), CStr(ARI(Z))

    Resume Next_Loop_Z

End Function