one sub routine required for sorting family tree

[Wasif1214]

My requirement is that family tree is required with sorting. Kindly check the snaps attached in which question shows how the data is & Answer shows the data in required format.
Code is performing above tasks perfectly with dictionaries used. Now, the requirement is that it should be done with 1 sub routine.
I am stuck that how it can be done with one sub routine as for family tree, iterative function is required.
Kindly check & any help is highly appreciated.

>>> use code - tags <<<

Sub Demo()
    Set nws = Worksheets("newsheet")
    Dim i As Long, j As Long, objDic As Object
    Dim arrData, rngData As Range, aRow(1 To 4)
    Dim sParent As String, sChild As String, sFirst As String
    Set rngData = nws.Range("A1").CurrentRegion    'A1
    ' load data into an array
    arrData = rngData.Value
    ReDim arrRes(1 To UBound(arrData), 1 To 4)
    ' populate header
    iR = 1
    For j = 1 To 4
        arrRes(iR, j) = arrData(1, j)
    Next
    Set objDic = CreateObject("scripting.dictionary")
    ' loop through data
    For i = LBound(arrData) To UBound(arrData)
        If arrData(i, 1) = 1 Then ' top node of each family
            If Len(sFirst) > 0 Then
                Call GetChild(objDic, "", sFirst)
                ' reset Dict
                objDic.RemoveAll
            End If
            sFirst = arrData(i, 3)
        End If
        sParent = arrData(i, 2): sChild = arrData(i, 3)
        If Not objDic.exists(sParent) Then
            Set objDic(sParent) = CreateObject("scripting.dictionary")
        End If
        ' get data row
        For j = 1 To 4
            aRow(j) = arrData(i, j)
        Next
        ' add to Dict
        objDic(sParent)(sChild) = aRow()
    Next i
    GetChild objDic, "", sFirst
    ' write output to sheet (starts from cell F1), modify as needed
    With nws.Range("F1").Resize(iR, 4)
        .EntireColumn.Clear
        .Value = arrRes
    End With
End Sub


Sub GetChild(oDic, sPar, sChi)
    Set nws = Worksheets("newsheet")
    Dim vKey, aRow, j As Long
    aRow = oDic(sPar)(sChi)
    iR = iR + 1
    ' populate output array
    For j = 1 To 4
        arrRes(iR, j) = aRow(j)
    Next
    '    Debug.Print Join(aRow, "|")
    If oDic.exists(sChi) Then
        For Each vKey In oDic(sChi).keys
            'get next level
            Call GetChild(oDic, sChi, vKey)
        Next
    End If
End Sub

 

[Marc L]

As the second VBA procedure is recursive - calling itself - then as it is that can't be done with a single procedure …​

The recursive code must be transformed to a non recursive way in order to be included into the main procedure.​

​

Or better just with a simple appropriate logic according to beginner level Excel basics as any dictionary is useless,​

should be achieved with less than 10 codelines !​

​

A reminder the best way to get help :​

Site Rules - New Users - Please Read

Hi all, Welcome to the Chandoo.org Forums. Posting Rules & Etiquette The Chandoo.org Forums is a collaborative and happy place to learn and expand your Excel knowledge. The Chandoo.org Forums consist of several Sub-Forums based on the type of question/area of Excel you are interested in...

chandoo.org

 

[Wasif1214]

Thanks for the response.
I do agree that recursive procedure can't be replaced by using dictionaries.
I have tried with basic logic by nesting loops & if but didn't get it done.
Big thanks for you if can i get that simple code because i am stuck. I use level as basic logic then at child but unable to get the job done.

 

[Marc L]

No, dictionary is very not a concern with a standard procedure or a recursive routine, whatever …​

This is just a logic question, why using several dictionaries when there are not necessary, what could be the benefit to over complicate ?!​

As looping is useless as well just using Excel basics (TEBV main rules 1/2 ) …​

As far I can guess with your pictures any Excel user can achieve it with 4 steps in a short time​

so the VBA procedure - if really necessary - can reproduce the same way with 6 codelines.​

But as guessing can't be coding, as any picture can't fill Excel with data, the reason why of my previous post link, a must read !​

Like advised before to log in so, without any workbook, I won't waste any time …​

​

 

[Wasif1214]

Kindly find workbook attached.
Kindly consider code in module 1 which is performing all the tasks listed below.
Macro ask user to select the range including headers in Row 1 from the worksheet name Table.
Macro prompt for newly created worksheet name & paste the family tree in newly created worksheet.
Kindly press cntrl+a as short cut for Macro to process in worksheet tab Table.
Kindly check the workbook & all the code in module 1. It have 6 procedures & requirement is all the steps done with one procedure & am facing difficulty for creating code specially for recursive functions to exclude.
Thanks for your time giving to the query & it means alot.

 

[Marc L]

According to your workbook attachment the 4 steps Excel basics VBA demonstration sorting the active worksheet :​

Sub Demo1()
   With [A1].CurrentRegion.Columns
       .Item(.Count + 1).Formula = "=IF(ISBLANK(B1),CHAR(63+ROW()),VLOOKUP(B1,C$1:" & .Cells(1, .Count + 1).Address(0) & _
                                   "," & .Count - 1 & ",FALSE)&CHAR(64+COUNTIF(B$1:B1,B1)))"
       .Item(.Count + 1).Formula = .Item(.Count + 1).Value
       .Resize(, .Count + 1).Sort .Item(.Count + 1), 1, Header:=1
       .Item(.Count + 1).Clear
   End With
End Sub

Do you like it ? So thanks to click on bottom right Like !​

​

 

[Wasif1214]

Sir
Hats off to you & i believe to hit the like button is minimum which can be done
Its amazing Sir, dont have words to pay my tribute sir

 

[Marc L]

Thanks. As a reminder my demonstration just reproduces what any Excel user - even a beginner - can operate manually !​

​

TEBV rule aka Think Excel Before VBA …​

​

 

[Marc L]

As I was in a hurry yesterday I forgot a crucial point if …​

The kid Excel beginner who solved my training based on this thread assumed the data is always ascending sorted on Level column.​

But if it's not always the case, like after running the VBA procedure, if a level #1 is after row #192 his formula should fail.​

And according to this formula a specific step was necessary.​

​

Now with the updated formula this revamped demonstration needs only 3 steps just desactivating the calculation :​

Sub Demo1r()
   With [A1].CurrentRegion.Columns
       .Item(.Count + 1).Formula = "=IF(ISBLANK(B1),CHAR(64+COUNTBLANK(B$1:B1)),VLOOKUP(B1,C$1:" & .Cells(1, .Count + 1).Address(0) _
                                 & "," & .Count - 1 & ",FALSE)&CHAR(64+COUNTIF(B$1:B1,B1)))"
        Application.Calculation = xlCalculationManual
       .Resize(, .Count + 1).Sort .Item(.Count + 1), 1, Header:=1
       .Item(.Count + 1).Clear
   End With
        Application.Calculation = xlCalculationAutomatic
End Sub

You may Like it !​

​

 

[Wasif1214]

Sir
Thanks alot for your support. Big Big thanks sir once again as how the complicated seems problems solve with simple logic sir.
Sir
If you have platform for Excel training, kindly let me know as want to join Sir to improve my excel skills sir.

 

[Marc L]

Thanks again. This is as simple as following Excel logic :​

why not just using the Excel sort feature rather than reinventing the wheel with the risk of a square one …​

​

I have no platform, just a kid who turned nut his mother during a Covid19 lockdown​

so I started to give him some pure logic training (reading Excel & VBA helps, thinking about some forum threads questions)​

as he looked interested when before I gave some help at his home to her mother to achieve an Excel project.​

After a couple of weeks he knew more about Excel than his mother …​

​