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

 

[MoshiM]

Here's one way of doing it. This function will return a collection so to avoid having to repeatedly run it, set it equal to a publicly declared collection variable and then retrieve the corresponding values by using the contents of Column A as a string.

Public Function Drew_Hierarchy() As Collection

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

Dim Total_Levels As Long, Current_Key As String

Total_Levels = 11
 
InputD = ActiveSheet.Range("A1", ActiveSheet.Cells(1, 1).End(xlDown).Offset(0, 12)).Value2

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

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

    For L = 1 To UBound(InputD, 2) 'Place current row into array
        Sub_R(L) = InputD(K, L)
    Next L
    
    Main_CLCTN.Add Sub_R 'Place array into collection keyed to what's in the first column
    
Next K

For Z = 1 To Main_CLCTN.Count

    Comparison_Array = Main_CLCTN(Z)
    Current_Key = CStr(Comparison_Array(1))
    With Sub_CLCTN
    
        For K = 1 To Main_CLCTN.Count 'Add all that meet the first criteria
        
            If K <> Z Then
            
                Sub_R = Main_CLCTN(K)
                
                If Sub_R(3) = Comparison_Array(3) Then .Add Sub_R
                
            End If
            
        Next K
        
        Erase Sub_R
        
        If .Count = 0 Then 'if there are no other rows matching
        
            Level = 3
            
            Output.Add Comparison_Array(Level + 2), Current_Key
        
        Else

            For Level = 2 To Total_Levels
            
                NthLevel = Level + 2
                
                For L = .Count To 1 Step -1 'Remove array rows that macth the the current level in the comparison array
                
                    If .ITEM(L)(NthLevel) <> Comparison_Array(NthLevel) Then
                        .Remove L
                    End If
                    
                Next L
                
                If .Count = 0 Then 'If all arrays have been removed
                    
                    Output.Add Comparison_Array(NthLevel), Current_Key
                    
                    Exit For
                    
                ElseIf Level = Total_Levels Then
            
                    Output.Add "Non-Unique Heiracrhy", Current_Key
                
                    Set Sub_CLCTN = Nothing
                
                End If
                
            Next Level
            
        End If
    
    End With
    
Next Z

Set Drew_Hierarchy = Output

End Function

 

[Peter_SSs]

Just wondering if it is possible that you could have data like this and would the result you want (if looking up 7654321) be $QWER?

Drew 2020-05-21 1.xlsm
	A	B	C	D	E	F	G	H	I	J
1	Cost Center -Leaf	CENTER_DESC	LEVEL_01	LEVEL_02	LEVEL_03	LEVEL_04	LEVEL_05	LEVEL_06	LEVEL_07	LEVEL_08
7	4444444	cc3	$	$D	$DB	$DAB	$DAAB	4444444	4444444	4444444
8	7654321	cc4	$	$D	$DA	$DAB	$QWER	7654321	7654321	7654321
9	6666666	cc5	$	$X	$DA	$DAB	$DAAB	7654321	7654321	7654321
Sheet1

BTW, I would also suggest

• Update your Account details (click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version. (Don’t forget to scroll down & ‘Save’)
• Investigate XL2BB for providing sample data

 

[MoshiM]

Just wondering if it is possible that you could have data like this and would the result you want (if looking up 7654321) be $QWER?

Maybe $DA since rows 8 and 9 differ on Level 2 but would also be $D if row 7 wasn't there.

 

[MoshiM]

Updated to allow 1D array or value input (doesn't have to be a string) if you want only certain values for Cost Center -Leaf. Will still output as a collection. Also there isn't error handling for if you have duplicate values for Cost Center -Leaf so add that yourself as I don't know how you want to handle it (when adding things to Main_CLCTN).

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

Dim K As Long, L As Long, Z As Long, Level As Long, NthLevel As Long, Removal_Count As Long, _
Main_CLCTN As New Collection, Sub_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_SUB_CLCTN_Addition As Boolean

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 'Deterimine number of dimensions if an array is supplied or change input into an array
       
        ARI = Cost_Center
       
        On Error Resume Next
       
        Do
            K = K + 1
            Z = LBound(ARI, K)
        Loop Until Err.Number <> 0
       
        On Error GoTo 0
       
        If K - 1 > 1 Then
       
            If UBound(ARI, 1) > 1 Then
           
                MsgBox "Array inputs must be 1-Dimensional. Exiting Function Drew_Hierarchy."
           
                Exit Function
               
            Else
           
                ARI = Application.Transpose(ARI)
               
            End If
           
        End If
       
    Else
   
        ARI = Array(Cost_Center)
       
    End If

End If

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

    For L = 1 To UBound(InputD, 2) 'splice current row of array into another array
        Sub_R(L) = InputD(K, L)
    Next L
   
    Main_CLCTN.Add Sub_R, CStr(Sub_R(1)) 'Place spliced array into collection
   
Next K

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

For Z = Min_Loop To Max_Loop

    If Not IsMissing(Cost_Center) Then
   
        On Error GoTo Key_Unknown
       
        Comparison_Array = Main_CLCTN(CStr(ARI(Z)))
       
        On Error GoTo 0
       
    Else
   
        Comparison_Array = Main_CLCTN(Z)
       
    End If
   
    Column_1_Key = CStr(Comparison_Array(1)) 'Key is whatever is in Column 1 of data range
   
    With Sub_CLCTN
   
        For K = 1 To Main_CLCTN.Count
           
            If Not IsMissing(Cost_Center) Then 'This conditional block ensures that the Comparison array isn't added to the Sub Collection
           
                If Main_CLCTN(K)(1) <> ARI(Z) Then Allow_SUB_CLCTN_Addition = True
               
            ElseIf K <> Z Then
           
                Allow_SUB_CLCTN_Addition = True
               
            End If
           
            If Allow_SUB_CLCTN_Addition = True Then 'Add all that match the first Level to Sub Collection
           
                Sub_R = Main_CLCTN(K)
               
                If Sub_R(3) = Comparison_Array(3) Then .Add Sub_R
               
                Allow_SUB_CLCTN_Addition = False
               
            End If

        Next K
       
        Erase Sub_R
       
        If .Count = 0 Then 'If there are no rows that at least match the first criteria then Hierarchy is unique
                           'Supply 3rd Level to Collection
            Level = 3
           
            Output.Add Comparison_Array(Level + 2), Column_1_Key
       
        Else

            For Level = 2 To Total_Levels
           
                NthLevel = Level + 2 'Level-2 starts in column 4..offset all levels by 2
               
                For L = .Count To 1 Step -1 'Remove arrays that match the current level in the comparison array
               
                    If .ITEM(L)(NthLevel) <> Comparison_Array(NthLevel) Then
                        .Remove L
                    End If
                   
                Next L
               
                If .Count = 0 Then 'If all arrays have been removed then the wanted Level has been identified
                   
                    Output.Add Comparison_Array(NthLevel), Column_1_Key
                   
                    Exit For
                   
                ElseIf Level = Total_Levels Then 'If on final loop and previous conditioanl wasn't executed
           
                    Output.Add "Non-Unique Hieracrhy", Column_1_Key
               
                    Set Sub_CLCTN = Nothing
               
                End If
               
            Next Level
           
        End If
   
    End With
   
Next_Loop_Z:

Next Z

Set Drew_Hierarchy = Output

Exit Function

Key_Unknown:

    Output.Add "Cost Center unavailable : " & ARI(Z), ARI(Z)
   
    Resume Next_Loop_Z
   
End Function

 

[MoshiM]

A few optimizations but will return 3rd level if there is another row that matches for all levels.

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_SUB_CLCTN_Addition 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 'Deterimine number of dimensions if an array is supplied or change input into an array
       
        ARI = Cost_Center
       
        On Error Resume Next
       
        Do
            K = K + 1
            Z = LBound(ARI, K)
        Loop Until Err.Number <> 0
       
        On Error GoTo 0
       
        If K - 1 > 1 Then
       
            If UBound(ARI, 1) > 1 Then
           
                MsgBox "Array inputs must be 1-Dimensional. Exiting Function Drew_Hierarchy."
           
                Exit Function
               
            Else
           
                ARI = Application.Transpose(ARI)
               
            End If
           
        End If
       
    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
       
    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
       
            On Error GoTo Key_Unknown
           
            Comparison_Array = .Item(CStr(ARI(Z)))
           
            On Error GoTo 0
           
        Else
       
            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 'Loop each array in the collection
           
            If Not IsMissing(Cost_Center) Then 'This conditional block ensures that the Comparison array isn't added to the Sub Collection
           
                If Main_CLCTN(K)(1) <> ARI(Z) Then Allow_SUB_CLCTN_Addition = True
               
            ElseIf K <> Z Then
           
                Allow_SUB_CLCTN_Addition = True
               
            End If
           
            If Allow_SUB_CLCTN_Addition = True Then 'Add all that match the first Level to Sub Collection
           
                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
                        GoTo Exit_K_Loop
                    If Sub_R(NthLevel) <> Comparison_Array(NthLevel) Then
                   
                        If NthLevel > Max_Level Then Max_Level = NthLevel
                       
                        Exit For
                       
                    End If
                   
                Next NthLevel
               
                Allow_SUB_CLCTN_Addition = False
               
            End If
   
        Next K
Exit_K_Loop:
        If Max_Level = 0 Then Max_Level = 5 'return 3rd Level if unique
       
        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), ARI(Z)
   
    Resume Next_Loop_Z
   
End Function

 

[MoshiM]

For post #6 change

If Sub_R(NthLevel) <> Comparison_Array(NthLevel)

to

ElseIf Sub_R(NthLevel) <> Comparison_Array(NthLevel)

 

[Drew]

WOW, it's working great! Thanks MoshiM for taking the time out of your day in creating the code.... I can follow the first posting and most of the last - I will spend more time to fully understand.
awesome, thanks again.

 

[MoshiM]

WOW, it's working great! Thanks MoshiM for taking the time out of your day in creating the code.... I can follow the first posting and most of the last - I will spend more time to fully understand.
awesome, thanks again.

I'm glad to hear that. I've updated the comments since they referenced the first version and not the updated one and also fixed a few potential bugs if you supply arguments to the function in array format.

Also if speed is an issue then it should be possible to skip parts of the loop if for example $JA doesn't appear in both Level 3 and another level. Just let me know and I'll edit it.

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
        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

 

[Drew]

Thank you again MoshiM... appreciate the time spent.
I'm weeding out what I don't need through a dictionary, then I'll pass the items array to the function ( got it down to less than 500 records vs the whole 25k dataset) so speed isn't factoring into the equation.
This will help out tremendously in our new process, taking out a manual task, and adding back automation.
Thanks again.