PDA

View Full Version : VBA to make formula for parent child



jbesclapez
05-08-2020, 10:03 AM
Hello,

I get regularly files with parent-child hierarchy in a unsorted way. My task it to first, sort it the way it should be sorted and then on another place make a graphical hieararchy in excel as it is easier to read.
I would like to have a formula that helps me do this. The formula would select the range for parent, then select the range for child, then select a cell where I can copy paste the sorted result of the hierarchy and another cell that would would display the graphical hierarchy. The formula could be called ParentChild and then would look like this
=ParentChild(A6:A10;C6:C10,F5,P2)
A6:A10 are the array of the parent
C6:C10 are the array of the parent and an error should pop up if the array as a different size (each child as a parent except the member Root)
F5 is the place were we will sort a clean hierarchy. Note that the F5 to Fx will be for the parent when G5 to Gx will be for the Child. Optional :This array should have no data before.
P2 is the place where the array will be paste. So if the hiearchy is 3 level deep than the hierarchy will be shown in a array from P2 to Sx - As P is the root, Q is level 1, R is level 2, S is level 3. Optional :This array should have no data before.
Note:The value in the formula are not static! It is not always A6:A10 for example!


Note that the depth of the hierarchy can change and is not know before.

So, in real life you get this file:



Pizza
Margerita


Root
HotDog


Root
Pizza


Margerita
Cheese


Pizza
Sea


Sea
Tuna


Burger
Bun


HotDog
Sausage


Sea
Shrimp


Root
Sandwich


Sandwich
Burger


Burger
Steack


Burger
Tomato


Burger
Cucumber


HotDog
Bun


Root
Offer


Offer
Pizza


Offer
Sandwich


Margerita
Tomato


Margerita
Oliva


Sea
Tomato


Sea
Cheese





Then it gets nicely sorted like this :




Root
Pizza


Pizza
Margerita


Margerita
Tomato


Margerita
Oliva


Margerita
Cheese


Pizza
Sea


Sea
Tuna


Sea
Shrimp


Sea
Tomato


Sea
Cheese


Root
Sandwich


Sandwich
Burger


Burger
Steack


Burger
Bun


Burger
Tomato


Burger
Cucumber


Root
HotDog


HotDog
Sausage


HotDog
Bun


Root
Offer


Offer
Pizza


Offer
Sandwich




And it creates the hierarchy like this : Optional: It should display graphically in excel like in the picture attached.


Root
Pizza






Margerita






Tomato





Oliva





Cheese




Sea






Tuna





Shrimp





Tomato





Cheese



Sandwich






Burger






Steack





Bun





Tomato





Cucumber




HotDog






Sausage





Bun



Offer






Pizza





Sandwich






26605

Thanks for your time and effort,


Have a good day,

SamT
05-08-2020, 02:27 PM
We don't need to see the Sorted List or the Text representation of the hierarchy. They actually get in the way.

I think a Ragged Array will hold the final Hierarchy Array regardless of its depth and width.

Planning that Ragged Array and coding to fill it will take some time to ponder.

Can you upload a workbook so we have some real data to work with. Use the Go Advanced button to post and upload files



Notes For Me:
Dim arMenu
Dim P,Q,R,S,T,U, and V as longs. Used to track up to 6 arMenu levels
Redim Preserve arMenu(0 to 1, 1 to Count of children + 1, 1 to 2) wherein 1 is the Parents' String
Next Step: fill Childrens Strings in arMenu(Q, 1 to Count)
Next Step: TBD

paulked
05-09-2020, 11:32 PM
I've gone as far as getting the data sorted but now a bit stuck, probably because my heads wrecked! I'll come back to it after a rest.

@Sam Without the text I wouldn't have spotted an error in the data!

Image of the output so far:
26618

jbesclapez
05-10-2020, 10:38 AM
Hi Guys and thanks for offering your help.
I managed to do the opposite of what I asked you and I was thinking to share that as now I need to revert it.

So in Column A to T I copy the third table of my first post. On the first row I write Level1, Level2....
Then after running the macro, I get the results in column V for child, W for parent and X the level.

I think instead of writting down the Level in the first row, I could use the column number as a Level numbering...

I hope it will help to make a formula.


Sub CreateChildParentHieararchy()


Dim lastRowi As Long
Dim lastRowj As Long
Dim ColX As Long
Dim RowY As Long
Dim p As Long
Dim i As Long


'Check First Parent in A2
If IsEmpty(Cells(2, 1)) = True Then
MsgBox "The Cell A2 cannot be empty. The macro will stop"
Exit Sub
Else
Range("V2:X65000").ClearContents
Range("A2").Copy
Range("V2").PasteSpecial Paste:=xlPasteValues
End If


'Check Last non empty row
For i = 1 To 19


lastRowi = ActiveSheet.Cells(Rows.Count, i).End(xlUp).row

If i > 1 Then
If lastRowi > lastRowj Then
lastRowj = lastRowi
End If
End If
Next i


'Search parent
For RowY = 3 To lastRowj
For ColX = 2 To 19
If IsEmpty(Cells(RowY, ColX)) = True Then 'If the cell is empty then do Nothing
'DoNothing
Else
Cells(RowY, 22) = Cells(RowY, ColX) ' Copy the cell value to V


For p = 0 To RowY - 1
If IsEmpty(Cells(RowY - p, ColX - 1)) = True Then
'DoNothing
Else
Cells(RowY, 23) = Cells(RowY - p, ColX - 1) ' Copy the first Parent
Exit For
End If
Next p
End If
Next ColX
Next RowY

'Search Level
For RowY = 3 To lastRowj
For ColX = 2 To 19
If IsEmpty(Cells(RowY, ColX)) = True Then 'If the cell is empty then do Nothing
'DoNothing
Else
'Mettre ici le code
Cells(RowY, 22) = Cells(RowY, ColX) ' Copy the cell value to V
For p = 0 To RowY - 1
If IsEmpty(Cells(RowY - p, ColX)) = True Then
'DoNothing
Else
Cells(RowY, 24) = Cells(RowY - p, ColX) ' Copy the first Parent
End If
Next p
End If
Next ColX
Next RowY

End Sub

paulked
05-10-2020, 10:49 AM
Try this:



Sub test()
Dim ar, arp, arc, arc1, art, i As Long, j As Long, k As Long, x As Long, y As Long, p As Long
Dim root As String, rw As Long, cl As Long, test As String, tm#

ar = Sheet1.Cells(1, 1).CurrentRegion
'Find Root
For i = 1 To UBound(ar)
test = ar(i, 1)
x = 0
For j = 1 To UBound(ar)
If ar(j, 2) = test Then x = 1
Next
If x = 0 Then root = test
Next
'Count parents
p = WorksheetFunction.CountIf(Range("a1:a" & UBound(ar)), root)
ReDim arp(1 To p, 1 To 1)
'Find parents
x = 0
For i = 1 To UBound(ar)
If ar(i, 1) = root Then
x = x + 1
arp(x, 1) = ar(i, 2)
End If
Next
'Get 1st children
ReDim arc(1 To UBound(arp, 1), 1 To 1)
For i = 1 To UBound(arp)
x = 0
For j = 1 To UBound(ar)
If ar(j, 1) = arp(i, 1) Then
x = x + 1
If UBound(arc, 2) < x Then ReDim Preserve arc(1 To p, 1 To x)
arc(i, x) = ar(j, 2)
End If
Next
Next
'Get 2nd children
y = UBound(arc, 1) * UBound(arc, 2)
p = 0
ReDim arc1(1 To y, 1 To 1)
For i = 1 To UBound(arc, 1)
'p = i - 1
For j = 1 To UBound(arc, 2)
p = p + 1
x = 0
For k = 1 To UBound(ar)
If arc(i, j) = ar(k, 1) Then
x = x + 1
If UBound(arc1, 2) < x Then ReDim Preserve arc1(1 To y, 1 To x)
arc1(p, x) = ar(k, 2)
End If
Next
Next
Next
ReDim art(1 To UBound(arc1, 1) * (UBound(arc1, 2) + 1), 1 To 7)
Range("d1:k60").ClearContents
'Fill 2nd Children
x = 0
While x < UBound(art, 1)
For i = 1 To UBound(arc1, 1)
For j = 1 To UBound(arc1, 2)
x = x + 1
art(x, 7) = arc1(i, j)
Next
x = x + 1
Next
Wend
'Fill 1st Children
x = 1
While x < UBound(art, 1)
For i = 1 To UBound(arc, 1)
For j = 1 To UBound(arc, 2)
'On Error Resume Next
art(x, 5) = arc(i, j)
x = x + 1 + UBound(arc1, 2)
Next

Next
Wend
'Fill Parents
x = 1
While x < UBound(art, 1)
For j = 1 To UBound(arp, 1)
art(x, 3) = arp(j, 1)
x = x + UBound(arc, 2) * (UBound(arc1, 2) + 1)
Next
Wend
'Fill root
art(1, 1) = root
Range("D:J").ClearContents
Application.ScreenUpdating = False
Range("d1", Cells(UBound(art, 1), UBound(art, 2) + 3)) = art
j = Cells(Rows.Count, 10).End(3).Row
k = Cells(Rows.Count, 8).End(3).Row
If j > k Then
i = j
Else
i = k
End If
For x = i To 2 Step -1
If x > j Then
If Cells(x, 8) = "" And Cells(x - 1, 8) = "" Then Range(Cells(x, 4), Cells(x, 10)).Delete shift:=xlUp
Else
If Cells(x, 10) = "" And Cells(x - 1, 10) = "" Then Range(Cells(x, 4), Cells(x, 10)).Delete shift:=xlUp
End If
Next
End Sub

paulked
05-10-2020, 10:55 AM
Hi Guys and thanks for offering your help.
I managed to do the opposite of what I asked you and I was thinking to share that as now I need to revert it.

:igiveup:

paulked
05-10-2020, 12:03 PM
I can't get your code to work.
So in Column A to T I copy the third table of my first post. There are only 4 columns, how do they fit in A to T?

Can you post your workbook?

jbesclapez
05-10-2020, 11:28 PM
I can't get your code to work. There are only 4 columns, how do they fit in A to T?

Can you post your workbook?

Hi Paul,
Well spotted! A to T because some columns are empty!
However, I am really happy with what you provided.
I will take over from that to tweak few things.

I am going to write also a new post regarding the same hierarchy but that needs to show in a graphical way. If you have time, may you please have a look at it?

Have a good day,