[COLOR=Navy]Sub[/COLOR] MG01Aug21
[COLOR=Navy]Dim[/COLOR] Rng [COLOR=Navy]As[/COLOR] Range
[COLOR=Navy]Dim[/COLOR] Dn [COLOR=Navy]As[/COLOR] Range
[COLOR=Navy]Dim[/COLOR] n [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
[COLOR=Navy]Dim[/COLOR] R [COLOR=Navy]As[/COLOR] Range
[COLOR=Navy]Dim[/COLOR] k [COLOR=Navy]As[/COLOR] Variant
[COLOR=Navy]Dim[/COLOR] c [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
[COLOR=Navy]Dim[/COLOR] Ex [COLOR=Navy]As[/COLOR] [COLOR=Navy]Integer[/COLOR]
[COLOR=Navy]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & 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
[COLOR=Navy]If[/COLOR] Not .exists(Dn.Value) [COLOR=Navy]Then[/COLOR]
.Add Dn.Value, Dn.Offset(, 1)
[COLOR=Navy]Else[/COLOR]
[COLOR=Navy]Set[/COLOR] .Item(Dn.Value) = Union(.Item(Dn.Value), Dn.Offset(, 1))
[COLOR=Navy]End[/COLOR] If
[COLOR=Navy]Next[/COLOR] Dn
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] k [COLOR=Navy]In[/COLOR] .keys
c = 1
Do
Ex = c
[COLOR=Navy]If[/COLOR] .exists(.Item(k)(c).Value) [COLOR=Navy]Then[/COLOR]
[COLOR=Navy]Set[/COLOR] .Item(k) = Union(.Item(k), .Item(.Item(k)(c).Value))
c = c + 1
[COLOR=Navy]End[/COLOR] If
Loop Until Ex = c
[COLOR=Navy]Next[/COLOR] k
Range("F1:G1") = Array("Parent", "Child")
n = 1
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] k [COLOR=Navy]In[/COLOR] .keys
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] R [COLOR=Navy]In[/COLOR] .Item(k)
n = n + 1
Cells(n, "F") = k
Cells(n, "G") = R
[COLOR=Navy]Next[/COLOR] R
[COLOR=Navy]Next[/COLOR] k
[COLOR=Navy]End[/COLOR] [COLOR=Navy]With[/COLOR]
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]
Try this:-
Results in "F & G"
Regards MickCode:[COLOR=Navy]Sub[/COLOR] MG01Aug21 [COLOR=Navy]Dim[/COLOR] Rng [COLOR=Navy]As[/COLOR] Range [COLOR=Navy]Dim[/COLOR] Dn [COLOR=Navy]As[/COLOR] Range [COLOR=Navy]Dim[/COLOR] n [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR] [COLOR=Navy]Dim[/COLOR] R [COLOR=Navy]As[/COLOR] Range [COLOR=Navy]Dim[/COLOR] k [COLOR=Navy]As[/COLOR] Variant [COLOR=Navy]Dim[/COLOR] c [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR] [COLOR=Navy]Dim[/COLOR] Ex [COLOR=Navy]As[/COLOR] [COLOR=Navy]Integer[/COLOR] [COLOR=Navy]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & 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 [COLOR=Navy]If[/COLOR] Not .exists(Dn.Value) [COLOR=Navy]Then[/COLOR] .Add Dn.Value, Dn.Offset(, 1) [COLOR=Navy]Else[/COLOR] [COLOR=Navy]Set[/COLOR] .Item(Dn.Value) = Union(.Item(Dn.Value), Dn.Offset(, 1)) [COLOR=Navy]End[/COLOR] If [COLOR=Navy]Next[/COLOR] Dn [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] k [COLOR=Navy]In[/COLOR] .keys c = 1 Do Ex = c [COLOR=Navy]If[/COLOR] .exists(.Item(k)(c).Value) [COLOR=Navy]Then[/COLOR] [COLOR=Navy]Set[/COLOR] .Item(k) = Union(.Item(k), .Item(.Item(k)(c).Value)) c = c + 1 [COLOR=Navy]End[/COLOR] If Loop Until Ex = c [COLOR=Navy]Next[/COLOR] k Range("F1:G1") = Array("Parent", "Child") n = 1 [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] k [COLOR=Navy]In[/COLOR] .keys [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] R [COLOR=Navy]In[/COLOR] .Item(k) n = n + 1 Cells(n, "F") = k Cells(n, "G") = R [COLOR=Navy]Next[/COLOR] R [COLOR=Navy]Next[/COLOR] k [COLOR=Navy]End[/COLOR] [COLOR=Navy]With[/COLOR] [COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]
Option Explicit
Dim rParents As Range
Dim lRow As Long
Sub ListDescendents()
Set rParents = Range("A2", Range("A2").End(xlDown))
lRow = 2
ListDescendents1 "", ""
Range("F2", Range("G2").End(xlDown)).Sort key1:=Range("F2"), order1:=xlAscending, key2:=Range("G2"), order2:=xlAscending
End Sub
Sub ListDescendents1(sChild As String, sAncestor As String)
Dim r As Range
For Each r In rParents
If r.Value = sChild Or sAncestor = "" Then
Range("F" & lRow) = IIf(sAncestor = "", r.Value, sAncestor)
Range("G" & lRow) = r.Offset(0, 1).Value
lRow = lRow + 1
ListDescendents1 r.Offset(0, 1).Value, IIf(sAncestor = "", r.Value, sAncestor)
End If
Next r
End Sub
Hi
Another option
Assuming a contiguous list starting in A2:B2, result in F2:G2 down, paste in a module and execute:
Code:Option Explicit Dim rParents As Range Dim lRow As Long Sub ListDescendents() Set rParents = Range("A2", Range("A2").End(xlDown)) lRow = 2 ListDescendents1 "", "" Range("F2", Range("G2").End(xlDown)).Sort key1:=Range("F2"), order1:=xlAscending, key2:=Range("G2"), order2:=xlAscending End Sub Sub ListDescendents1(sChild As String, sAncestor As String) Dim r As Range For Each r In rParents If r.Value = sChild Or sAncestor = "" Then Range("F" & lRow) = IIf(sAncestor = "", r.Value, sAncestor) Range("G" & lRow) = r.Offset(0, 1).Value lRow = lRow + 1 ListDescendents1 r.Offset(0, 1).Value, IIf(sAncestor = "", r.Value, sAncestor) End If Next r End Sub
Example:
A B C D E F G H 1 Parent Child Element Descendents 2 A B A B 3 B C A C 4 C D A D 5 E F A E 6 F G A F 7 B H A G 8 A I A H 9 D K A I 10 K J A J 11 C E A K 12 K L A L 13 J M A M 14 B C 15 B D 16 B E 17 B F 18 B G 19 B H 20 B J 21 B K 22 B L 23 B M 24 C D 25 C E 26 C F 27 C G 28 C J 29 C K 30 C L 31 C M 32 D J 33 D K 34 D L 35 D M 36 E F 37 E G 38 F G 39 J M 40 K J 41 K L 42 K M 43 [Book1]Sheet1
<tbody>
</tbody>
Range("F2", Range("G2").End(xlDown)).Sort Key1:=Range("F2"), Order1:=xlAscending, Key2:=Range("G2"), Order2:=xlAscending, [B][COLOR=#a52a2a]Header:=xlNo[/COLOR][/B]