Extracting multi level connection from parent and child column

[shriexcel]

Greetings All,

i have data set consisting of parent and child connections. I need to find a way to extract parent its child and its child's child and so on. Data structure is like this

[TABLE="width: 100"]
<tbody>[TR]
[TD]Parent[/TD]
[TD]Child[/TD]
[/TR]
[TR]
[TD]A[/TD]
[TD]B[/TD]
[/TR]
[TR]
[TD]A[/TD]
[TD]C[/TD]
[/TR]
[TR]
[TD]B[/TD]
[TD]D[/TD]
[/TR]
[TR]
[TD]C[/TD]
[TD]E[/TD]
[/TR]
[TR]
[TD]C[/TD]
[TD]F[/TD]
[/TR]
[TR]
[TD]F[/TD]
[TD]G[/TD]
[/TR]
[TR]
[TD]F[/TD]
[TD]H[/TD]
[/TR]
[TR]
[TD]F[/TD]
[TD]I[/TD]
[/TR]
[TR]
[TD]G[/TD]
[TD]J[/TD]
[/TR]
[TR]
[TD]G[/TD]
[TD]K[/TD]
[/TR]
</tbody>[/TABLE]
My formula is very rough and takes so much time to run it. I am looking for a faster way to make this connection.
My code runs the loop find top parent
Run the loop and find where child is parent
print out both the information and keeps on going.

My data has almost 8000-10000 lines and running the loop through them again and again is taking time (almost 15 minutes) and crashing my excel.

 

[MickG]

Perhaps this:-
Results in Column "D".

[COLOR="Navy"]Sub[/COLOR] MG22Sep24
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] K, oVal [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] Nstr [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
c = 1
Range("D1").Value = "P to C"
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))
    [COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng: .Item(Dn.Value) = Dn.Offset(, -1).Value: [COLOR="Navy"]Next[/COLOR]
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
        Nstr = K: oVal = K
        [COLOR="Navy"]Do[/COLOR] [COLOR="Navy"]While[/COLOR] .exists(oVal)
            Nstr = Nstr & "," & .Item(oVal)
            oVal = .Item(oVal)
        [COLOR="Navy"]Loop[/COLOR]
            c = c + 1
            Cells(c, "D") = StrReverse(Nstr): Nstr = ""
    [COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick