Line of succession based on family tree

Question

I have following data in Excel.

I need above data in below format.

As Elizabeth II has child Charles & Charles has child then Charles will be in the next line after Elizabeth & same for the remaining.

Sub final()

Dim i, j, a, lrr, b, c, d, e, f As Long
Dim nm, nm1, nm2 As String
Dim rng As Range

lrr = Sheet5.Cells(Rows.Count, "A").End(xlUp).Row
i = 1
'finding max number
If lrr > 1 Then
   Set rng = Sheet5.Range("A1:A" & lrr)
   a = Application.WorksheetFunction.Max(rng)
End If
b = 2
c = 2

For i = 2 To lrr
    nm = Sheet5.Cells(b, 13).Value      
    For c = i + 1 To lrr      
        If Sheet5.Cells(c, 12).Value = nm Then    
            Sheet5.Cells(c + 1, 16).Value = Sheet5.Cells(c, 11).Value
            Sheet5.Cells(c + 1, 17).Value = Sheet5.Cells(c, 12).Value
            Sheet5.Cells(c + 1, 18).Value = Sheet5.Cells(c, 13).Value
            Sheet5.Cells(c + 1, 19).Value = Sheet5.Cells(c, 14).Value
            'a = a + 1
            c = c + 1
       
            e = Sheet5.Cells(c, 16).Value
            ' nm2 = Sheet5.Cells(c, 18).Value
            While e <= a         
                For j = c To lrr
                    nm2 = Sheet5.Cells(c, 18).Value             
                    If Sheet5.Cells(j, 12).Value = nm2 Then
                        'e = Sheet5.Cells(c, 16).Value
                        Sheet5.Cells(c + 1, 16).Value = Sheet5.Cells(j, 11).Value
                        Sheet5.Cells(c + 1, 17).Value = Sheet5.Cells(j, 12).Value
                        Sheet5.Cells(c + 1, 18).Value = Sheet5.Cells(j, 13).Value
                        Sheet5.Cells(c + 1, 19).Value = Sheet5.Cells(j, 14).Value
                        'a = a + 1
                        c = c + 1
                        e = Sheet5.Cells(c, 16).Value
                        If e = 5 Then
                            nm2 = Sheet5.Cells(c, 17).Value
                            f = j
                            For f = j + 1 To lrr
                                If Sheet5.Cells(f, 12).Value = nm2 Then
                                    Sheet5.Cells(c + 1, 16).Value = Sheet5.Cells(f, 11).Value
                                    Sheet5.Cells(c + 1, 17).Value = Sheet5.Cells(f, 12).Value
                                    Sheet5.Cells(c + 1, 18).Value = Sheet5.Cells(f, 13).Value
                                    Sheet5.Cells(c + 1, 19).Value = Sheet5.Cells(f, 14).Value
                                    'a = a + 1
                                    c = c + 1
                                End If                   
                            Next
                        End If                                
                    End If 
                Next
                e = e + 1
            Wend        
        End If
    Next
Next
End Sub

I get till first part and code is not going for the other parts as given below.

Answer 1

• Use nested Dict object to store data
• Use a recursive function to retrieve parent-child chain

Microsoft documentation:

Dictionary object

Range.CurrentRegion property (Excel)

Range.Resize property (Excel)

Option Explicit
Dim arrRes(), iR As Long
Sub Demo()
    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 = ActiveSheet.Range("A1").CurrentRegion
    ' 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 ActiveSheet.Range("F1").Resize(iR, 4)
        .EntireColumn.Clear
        .Value = arrRes
    End With
End Sub

' recursive function to get the child node
Sub GetChild(oDic, sPar, sChi)
    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