I want to have VBA code for family tree. I believe its quite simple but i am unable to do it, Any help will be highly appreciated

Question

I have following data in Excel

I need above data in below format. Kindly let me know VBA code for this.

As elzibethII has child Charles & charles has child then charles will be in the next line after elzibeth & same for the remaining.

I have try different VBA codes with different scenarios but unfortunately its not quite successful

The code is given below

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 am getting till 1st 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