Ребенок	Dlt	MaxG	MinG	Cnt
 72771 	 8 	 39 	 31 	 90 
 72768 	 8 	 38 	 30 	 90 
 72767 	 8 	 38 	 30 	 90 
 72766 	 8 	 38 	 30 	 90 
 54240 	 8 	 40 	 32 	 87 
 54223 	 8 	 39 	 31 	 87 

SELECT потомки.Ребенок,
 Max([iGeneration])-Min([iGeneration]) AS Dlt,
 Max(потомки.iGeneration) AS MaxG,
 Min(потомки.iGeneration) AS MinG,
 Count(*) AS Cnt
FROM потомки
GROUP BY потомки.Ребенок
HAVING (((Count(*))> 1 ))
ORDER BY Max([iGeneration])-Min([iGeneration]) DESC ,
 Count(*) DESC ,
 Max(потомки.iGeneration) DESC ,
 Min(потомки.iGeneration);

Ребенок	Dlt	MaxG	MinG	Cnt
 29018 	 5 	 39 	 34 	 421 
 29017 	 5 	 39 	 34 	 421 
 29019 	 5 	 39 	 34 	 421 
 29020 	 5 	 39 	 34 	 421 
 29021 	 5 	 39 	 34 	 421 
 29015 	 5 	 38 	 33 	 237 

SELECT потомки.Ребенок,
 Max([iGeneration])-Min([iGeneration]) AS Dlt,
 Max(потомки.iGeneration) AS MaxG,
 Min(потомки.iGeneration) AS MinG,
 Count(*) AS Cnt
FROM потомки
GROUP BY потомки.Ребенок
HAVING (((Count(*))> 1 ))
ORDER BY Count(*) DESC ,
 Max([iGeneration])-Min([iGeneration]) DESC ,
 Max(потомки.iGeneration) DESC ,
 Min(потомки.iGeneration);

Option Compare Database
Option Explicit
  Private dbs As Database, rstDesc As Recordset, rstS As Recordset, rstD As Recordset
  
Sub start(id As Long)
    Set dbs = CurrentDb
    dbs.Execute ("Delete From потомки")
    Set rstDesc = dbs.OpenRecordset("потомки")
    FindDescendant id,  1  '29, 1
    rstDesc.Close
    Set rstDesc = Nothing
End Sub


Sub FindDescendant(id As Long, iGeneration As Long)
    
    Dim i As Long, rst As Recordset, n As Long
    Set rst = dbs.OpenRecordset("SELECT ребенок FROM семьи LEFT JOIN дети ON семьи.id=дети.семья WHERE Not ребенок Is Null AND (муж=" & id & " OR жена=" & id & ")")
    With rst
        Do While Not .EOF
            n = .Fields(0)
            With rstDesc
                On Error Resume Next
                .AddNew
                .Fields(0) = n
                .Fields(1) = iGeneration
                .Update
            End With
            If Err = 0 Then
                i = iGeneration + 1
                FindDescendant .Fields(0), i
            End If
            On Error GoTo 0
            .MoveNext
        Loop
    End With
    rst.Close
    Set rst = Nothing
End Sub

Sub startT(id As Long)
    Set dbs = CurrentDb
    dbs.Execute ("Delete From потомки")
    Set rstDesc = dbs.OpenRecordset("потомки")
    Set rstS = dbs.OpenRecordset("семьи", dbOpenTable)
    Set rstD = dbs.OpenRecordset("дети", dbOpenTable)
    rstD.Index = "СемьяРебенок"
    FindDescendantT id, 1 '29,  1 
    rstDesc.Close
    Set rstDesc = Nothing
    rstS.Close
    Set rstS = Nothing
    rstD.Close
    Set rstD = Nothing
End Sub
Sub FindDescendantT(id As Long, iGeneration As Long)
    Dim i As Long, nS As Long, nR As Long, iSx As Long
    Dim sIn( 0  To  1 ) As String
    
    sIn( 0 ) = "Мid": sIn( 1 ) = "Жid"
    For iSx =  0  To  1 
        With rstS
            .Index = sIn(iSx)
            .Seek ">=", id,  0 
            If Not .NoMatch Then
                Do While .Fields(iSx +  1 ) = id
                    nS = .Fields("id")
                    With rstD
                        .Seek ">=", nS,  0 
                        If Not rstD.NoMatch Then
                            Do While .Fields("Семья") = nS
                                nR = .Fields("Ребенок")
                                With rstDesc
                                    On Error Resume Next
                                    .AddNew
                                    .Fields( 0 ) = nR
                                    .Fields( 1 ) = iGeneration
                                    .Update
                                End With
                                If Err =  0  Then
                                    i = iGeneration +  1 
                                    FindDescendantT nR, i
                                    .Seek ">", nS, nR
                                Else
                                    .MoveNext
                                End If
                                On Error GoTo  0 
                                If .NoMatch Or .EOF Then Exit Do
                            Loop
                        End If
                    End With
                    .Index = sIn(iSx) 'мог смениться
                    .Seek ">", id, nS
                    If .NoMatch Then Exit Do
                Loop
            End If
        End With
    Next iSx
End Sub

Ребенок	Dlt	MaxG	MinG	Cnt
 29014 	 17 	 43 	 26 	 18 
 33567 	 17 	 43 	 26 	 18 
 33568 	 17 	 43 	 26 	 18 
 27295 	 17 	 43 	 26 	 18 
 33563 	 17 	 43 	 26 	 18 
 17191 	 17 	 42 	 25 	 18 

Option Compare Database
Option Explicit
Private dbs As Database, rstDesc As Recordset, rstS( 0  To  1 ) As Recordset, rstD As Recordset ', n As Long
Private pC() As Long, pN() As Long

Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)


Sub startA(id As Long, Optional bMod As Boolean)
    Dim iSx As Long
    Dim sIn(0 To 1) As String
Dim Start_t As Double
    Start_t = Timer
    Set dbs = CurrentDb
    dbs.Execute ("Delete From потомки")
    Set rstDesc = dbs.OpenRecordset("потомки")
    
    sIn(0) = "Мid": sIn(1) = "Жid"
    For iSx = 0 To 1
        Set rstS(iSx) = dbs.OpenRecordset("семьи", dbOpenTable)
        rstS(iSx).Index = sIn(iSx)
    Next iSx

    Set rstD = dbs.OpenRecordset("дети", dbOpenTable)
    rstD.Index = "СемьяРебенок"
    FindDescendantAll id, 1, bMod '29,  1 
    rstDesc.Close
    Set rstDesc = Nothing
    For iSx =  0  To  1 
        rstS(iSx).Close
        Set rstS(iSx) = Nothing
    Next iSx
    rstD.Close
    Set rstD = Nothing
    Debug.Print Timer - Start_t
End Sub

Sub FindDescendantAll(id As Long, iGeneration As Long, Optional bMod As Boolean)
Dim nP As Long, nC As Long, iG As Long, bF As Boolean
Dim iC As Long

    'On Error Resume Next
    bF = FindDescendantA(id, iGeneration)   'первый вызов
    iG = iGeneration
    Do While bF  'цикл по поколениям
        'переместим следующих в текущий
        Erase pC
        ReDim pC( 0  To UBoundE(pN))
        If bMod Then
            'сдвиг указателей
            'CopyMemory pC( 0 ), pN( 0 ), x * (UBound(pN) +  1 )
            'где x - количество байт в элементе массива - для инт - 2 для лонга 4
            CopyMemory pC(0), pN(0), 4 * (UBoundE(pN) + 1)
        Else
            For iC = 0 To UBound(pN)
                pC(iC) = pN(iC)
            Next iC
        End If
        Erase pN    'очистка следующего
        bF = False
        iG = iG +  1 
        For nC =  0  To UBound(pC)
            bF = FindDescendantA(pC(nC), iG) Or bF
        Next nC
    Loop
End Sub

Function UBoundE(Ar As Variant) As Long
    On Error Resume Next
    UBoundE = UBound(Ar)
    If Err <>  0  Then UBoundE = - 1 
End Function

Function FindDescendantA(id As Long, iGeneration As Long) As Boolean
    Dim i As Long, nS As Long, nR As Long, iSx As Long
    Dim kN As Long
    
    For iSx =  0  To  1 
        With rstS(iSx)
            '.Index = sIn(iSx)
            .Seek ">=", id, 0
            If Not .NoMatch Then
                Do While .Fields(iSx + 1) = id
                    nS = .Fields("id")
                    With rstD
                        .Seek ">=", nS ',  0 
                        If Not rstD.NoMatch Then
                            Do While .Fields("Семья") = nS
                                nR = .Fields("Ребенок")
                                With rstDesc
                                    On Error Resume Next
                                    .AddNew
                                    .Fields( 0 ) = nR
                                    .Fields( 1 ) = iGeneration
                                    .Update
                                End With
                                If Err =  0  Then
                                    i = iGeneration +  1 
                                    FindDescendantA = True 'есть хоть один
                                    kN = UBoundE(pN) + 1
                                    ReDim Preserve pN(0 To kN)
                                    pN(kN) = nR 'вызовем потом
                                Else
                                End If
                                On Error GoTo  0 
                                .MoveNext
                                If .NoMatch Or .EOF Then Exit Do
                            Loop
                        End If
                    End With
                    '.Seek ">", id, nS
                    .MoveNext
                    If .NoMatch Or .EOF Then Exit Do
                Loop
            End If
        End With
    Next iSx
End Function