Public Function GetRelated(ByVal id As Integer) As Scripting.Dictionary
    Dim rv As New Scripting.Dictionary

    Dim irs As DAO.Recordset
    Set irs = CurrentDb.OpenRecordset("SELECT * FROM [Copy Of Transactions] where Related = " & id & " or ID=" & id)
     If Not (irs.EOF And irs.BOF) Then
         irs.MoveFirst
         Do Until irs.EOF = True
                Dim rsid As Integer
                rsid = irs("ID")
                If Not rv.Exists(rsid) Then rv.Add rsid, rsid
                If Not IsNull(irs("Related")) Then rsid = irs("Related")
                If Not rv.Exists(rsid) Then rv.Add rsid, rsid
             irs.MoveNext
         Loop
     End If
     Set GetRelated = rv
End Function

Function CloneDictionary(Dict)
  Dim newDict
  Set newDict = CreateObject("Scripting.Dictionary")

  For Each Key In Dict.Keys
    newDict.Add Key, Dict(Key)
  Next
  newDict.CompareMode = Dict.CompareMode

  Set CloneDictionary = newDict
End Function

Public Function Lookup_chains(in_id As Integer) As Scripting.Dictionary

Dim rs As DAO.Recordset
Dim ids As New Scripting.Dictionary
Dim oldCount As Integer
ids.Add in_id, in_id
While newCount <> ids.Count
    Dim td As Scripting.Dictionary
    Set td = CloneDictionary(ids)

    For Each tdKey In td.Keys
        newCount = ids.Count
        Dim id As Integer
        Dim newIds As Scripting.Dictionary
        Set newIds = GetRelated(tdKey)
        For Each Item In newIds
            Dim x As Integer
            On Error Resume Next
            ids.Add Item, Item
        Next
    Next
Wend
    Set Lookup_chains = ids
End Function
Public Sub process_related()
    Dim irs As DAO.Recordset
    Set irs = CurrentDb.OpenRecordset("SELECT * FROM [Copy Of Transactions]")
     If Not (irs.EOF And irs.BOF) Then
         irs.MoveFirst
         Do Until irs.EOF = True
                Dim rsid As Integer
                rsid = irs("ID")
                    Dim ids As New Scripting.Dictionary
                    Set ids = Lookup_chains(rsid)
                    Dim i As Integer
                    i = 0
                    Dim cond As String
                    cond = ""
                    For Each Key In ids.Keys
                        If i = 0 Then i = Key
                        If Len(cond) > 0 Then
                            cond = cond & "," & CStr(Key)
                        Else: cond = CStr(Key)
                        End If
                        If i > Key Then i = Key
                    Next
                    Dim q As String
                    q = "Update [Copy of Transactions] set MetaID = " & i & ", Related = " & i & " where ID in (" & cond & ")"
                    CurrentDb.Execute q
                 irs.MoveNext
         Loop
     End If

End Sub