Organization Chart with VBA – Part 5

Option Explicit
Public dictA As Dictionary, dictC As Dictionary
Dim fs As Worksheet, h%, w%, parr, dt As Worksheet

Sub RefList()
Dim lr%, lastcell As Range, lc%, r%
Set fs = Sheets("final")
Set dt = Sheets("tdata")
lr = Split(fs.[a1].CurrentRegion.Address, "$")(4)
Application.CutCopyMode = False
fs.Range("B1:B" & lr).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=fs.[H4], Unique:=True
r = 5
fs.[j4] = fs.[H4]
Do While Len(fs.Cells(r, "h")) And r < 20
    fs.[j5] = fs.Cells(r, "h")
    fs.Range("a1:b" & lr).AdvancedFilter xlFilterCopy, fs.[j4:j5], fs.[L4], False
    fs.[j5].Copy Sheets("tdata").Cells(74, 17 + r)
    Set lastcell = fs.[L:L].Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
    lc = Split(lastcell.Address, "$")(2)
    fs.Range("L5:L" & lc).Copy dt.Cells(75, 17 + r)
    r = r + 1
    fs.[L4].CurrentRegion.Delete
Loop
End Sub

Sub User_form()
UserForm1.Show vbModeless
End Sub

Sub main()                                                  ' run me
Dim i%, ob As Worksheet, r As Range, tb As Shape, t
Set dt = Sheets("tdata")
Set ob = Sheets("final")
h = 1: w = 1
ob.[h:k].ClearContents
Set tb = dt.Shapes.AddTextbox(msoTextOrientationHorizontal, 500, 70, 50, 50)
tb.TextFrame2.TextRange.Text = "Milou"
tb.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
tb.TextFrame2.WordWrap = msoFalse
tb.TextFrame2.TextRange.Font.Size = 16
For i = 1 To ob.Range("a" & Rows.Count).End(xlUp).Row       ' determine big shape size
    tb.TextFrame2.TextRange.Text = Cells(i, 1) & vbLf & Cells(i, 3)
    If tb.Height > h Then h = tb.Height
    If tb.Width > w Then w = tb.Width
Next
Application.CutCopyMode = 0
dt.Cells.ClearContents
ob.[a1].CurrentRegion.Copy                                  ' original table
Sheets("secondary").[bb1].PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
For i = ob.Shapes.Count To 1 Step -1
    If Not ob.Shapes(i).Name Like "*ommand*" Then ob.Shapes(i).Delete
Next
ob.Activate
Phase1
Phase2 True, False                                            ' move shapes
Phase2 False, False                                           ' update table
Horiz
Sheets("secondary").[bb1].CurrentRegion.Copy
ob.Range("a1").PasteSpecial xlPasteAll, xlPasteSpecialOperationNone, False, False
Set r = dt.Range("b:b").Find(WorksheetFunction.Min(dt.[b:b]), dt.[b1], xlValues, xlWhole)
ob.Rows(CStr(Split(ob.[a1].CurrentRegion.Address, "$")(4) + 2) & ":" & _
CStr(Split(ob.Shapes(r.Offset(, -1)).TopLeftCell.Address, "$")(2) - 2)).Delete      ' rows above chart
For i = ob.Shapes.Count To 1 Step -1
t = ob.Shapes(i).TextFrame2.TextRange.Text
    If Len(t) And (t Like "*dumm*" Or t Like "top") Then ob.Shapes(i).Delete
    Next
GroupShapes True                                                ' top to bottom
Rem RecPic                                                          ' two colours per box
ob.[x:af].ClearContents
ob.[x:af].Interior.Pattern = xlNone
End Sub

Sub Phase3()                                                  ' draws connectors
Dim v, r As Range, lasto%, i%, y1, y2, yf, x1, x2, ws As Worksheet, _
dt As Worksheet, j%, boss$, nr%, rr As Range, ori As Worksheet
Set ori = Sheets("original")
Set ws = Sheets("final")
Set dt = Sheets("tdata")
dt.[a1:ab70].ClearContents
ws.[a1].CurrentRegion.Copy dt.[a1]
dt.Activate
[g1] = [b1]
v = Split([a1].CurrentRegion.Address, "$")(4)
Range("b1:b" & v).AdvancedFilter xlFilterCopy, [g1:g2], [k1], True
For j = 75 To Range("a" & Rows.Count).End(xlUp).Row
    If Not Cells(j, 4) Like "top" And Not Cells(j, 4) Like "dumm*" Then
        Cells(j, 2) = ws.Shapes(Cells(j, 1)).Top
        Cells(j, 3) = ws.Shapes(Cells(j, 1)).Left
    End If
Next
For j = 2 To Range("k" & Rows.Count).End(xlUp).Row
Set rr = ori.Range("y:y").Find(dt.Cells(j, "k"), ori.[y1], xlValues, xlWhole)
If Not rr Is Nothing Then
If rr.Offset(, 2) < 2 Then
    [m1:z70].ClearContents
    [m1] = [g1]
    [m2] = Cells(j, "k")
    Range("a1:b" & v).AdvancedFilter xlFilterCopy, [m1:m2], [n1], False
    Set r = [d:d].Find([m2], [d1], xlValues, xlWhole)
    [q1] = [d74]
    [q2] = [m2]
    nr = Range("n" & Rows.Count).End(xlUp).Row
    For i = 2 To nr
        Cells(i + 1, "q").FormulaR1C1 = "=""=" & Cells(i, "n") & """"       ' exact match
    Next
    lasto = Split(Range("q1").CurrentRegion.Address, "$")(4)
    Range("a74:g" & Range("a" & Rows.Count).End(xlUp).Row).AdvancedFilter _
    xlFilterCopy, Range("q1:q" & lasto), [s1], False
    y1 = WorksheetFunction.Min([t:t]) + WorksheetFunction.Max([w:w])
    yf = y1 + (WorksheetFunction.Max([t:t]) - y1) / 2
    x1 = WorksheetFunction.Min([u:u]) + (WorksheetFunction.Max([y:y]) / 2)
    x2 = WorksheetFunction.Max([u:u]) + (WorksheetFunction.Max([y:y]) / 2)
    With ws.Shapes.AddLine(x1, yf, x2, yf).Line                              ' horizontal
        .DashStyle = msoLineSolid
        .ForeColor.RGB = RGB(50, 40, 130)
        .Weight = 2
    End With
    Set r = Range("v:v").Find([m2], [v1], xlValues, xlWhole)
    x1 = r.Offset(, -1) + r.Offset(, 3) / 2
    Set r = dt.[f:f].Find(1, dt.[f1], xlValues, xlWhole)                      ' level one
    boss = r.Offset(, -5)
    If [m2] = r.Offset(, -2) And nr Mod 2 = 0 Then                            ' big boss
        dt.[u:u].Copy dt.[aa1]
        Set r = dt.Range("aa:aa").Find(r.Offset(, -3), dt.[aa1], xlValues, xlWhole)
        r = 10000                                                             ' big number
        Sorter "aa", 2, dt
        ws.Shapes(boss).Left = dt.Cells(4 + (Range("aa" & Rows.Count).End(xlUp).Row - 5) / 2, "aa")
        x1 = ws.Shapes(boss).Left + ws.Shapes(boss).Width / 2
    End If
    With ws.Shapes.AddLine(x1, y1, x1, yf).Line     ' father to horizontal line
        .DashStyle = msoLineSolid
        .ForeColor.RGB = RGB(50, 40, 130):    .Weight = 2
    End With
    For i = 2 To Range("n" & Rows.Count).End(xlUp).Row                       ' sons to horizontal line
        Set r = Range("v:v").Find(Cells(i, "n").Value, [v1], xlValues, xlWhole)
        x1 = r.Offset(, -1) + r.Offset(, 3) / 2
        With ws.Shapes.AddLine(x1, r.Offset(, -2), x1, yf).Line
            .DashStyle = msoLineSolid
            .ForeColor.RGB = RGB(50, 40, 130)
            .Weight = 2
        End With
    Next
    End If
    End If
Next
On Error Resume Next
For i = 1 To ws.Shapes.Count
    If Not ws.Shapes(i).TextFrame2.TextRange.Text Like "*%*" Then _
    ws.Shapes(i).TextFrame2.TextRange.Font.Size = 16
Next
On Error GoTo 0
End Sub

Sub Phase4()                                                  ' draws connectors multiple parents
Dim v, r As Range, lasto%, i%, y1, y2, yf, x1, x2, ws As Worksheet, _
dt As Worksheet, j%, boss$, nr%, rr As Range, ori As Worksheet
Set ori = Sheets("original")
Set ws = Sheets("final")
Set dt = Sheets("tdata")
dt.[a1:ab70].ClearContents
ws.[a1].CurrentRegion.Copy dt.[a1]
dt.Activate
[g1] = [b1]
v = Split([a1].CurrentRegion.Address, "$")(4)
ori.[ac30:ac45].Copy dt.[k1]
For j = 75 To Range("a" & Rows.Count).End(xlUp).Row
    If Not Cells(j, 4) Like "top" And Not Cells(j, 4) Like "dumm*" Then
        Cells(j, 2) = ws.Shapes(Cells(j, 1)).Top
        Cells(j, 3) = ws.Shapes(Cells(j, 1)).Left
    End If
Next
For j = 2 To Range("k" & Rows.Count).End(xlUp).Row
Set rr = ori.Range("z:z").Find(dt.Cells(j, "k"), ori.[z1], xlValues, xlWhole)
If Not rr Is Nothing Then
If rr.Offset(, 2) > 1 Then
    [m1:z70].ClearContents
    [m1] = [a1]
    [m2] = Cells(j, "k")
    ori.[y30:z60].AdvancedFilter xlFilterCopy, [m1:m2], [n1], False
    Set r = [d:d].Find([m2], [d1], xlValues, xlWhole)
    [q1] = [d74]
    [q2] = [m2]
    nr = Range("n" & Rows.Count).End(xlUp).Row
    For i = 2 To nr
        Cells(i + 1, "q").FormulaR1C1 = "=""=" & Cells(i, "n") & """"       ' exact match
    Next
    lasto = Split(Range("q1").CurrentRegion.Address, "$")(4)
    Range("a74:g" & Range("a" & Rows.Count).End(xlUp).Row).AdvancedFilter _
    xlFilterCopy, Range("q1:q" & lasto), [s1], False
    y1 = WorksheetFunction.Min([t:t]) + WorksheetFunction.Max([w:w])
    yf = y1 + (WorksheetFunction.Max([t:t]) - y1) / 2
    x1 = WorksheetFunction.Min([u:u]) + (WorksheetFunction.Max([y:y]) / 2)
    x2 = WorksheetFunction.Max([u:u]) + (WorksheetFunction.Max([y:y]) / 2)
    With ws.Shapes.AddLine(x1, yf, x2, yf).Line                              ' horizontal
        .DashStyle = msoLineSolid
        .ForeColor.RGB = RGB(50, 40, 130)
        .Weight = 2
    End With
    Set r = Range("v:v").Find([m2], [v1], xlValues, xlWhole)
    x1 = r.Offset(, -1) + r.Offset(, 3) / 2
    Set r = dt.[f:f].Find(1, dt.[f1], xlValues, xlWhole)                      ' level one
    boss = r.Offset(, -5)
    If [m2] = r.Offset(, -2) And nr Mod 2 = 0 Then                            ' big boss
        dt.[u:u].Copy dt.[aa1]
        Set r = dt.Range("aa:aa").Find(r.Offset(, -3), dt.[aa1], xlValues, xlWhole)
        r = 10000                                                             ' big number
        Sorter "aa", 2, dt
        ws.Shapes(boss).Left = dt.Cells(4 + (Range("aa" & Rows.Count).End(xlUp).Row - 5) / 2, "aa")
        x1 = ws.Shapes(boss).Left + ws.Shapes(boss).Width / 2
    End If
    y1 = WorksheetFunction.Max([t:t])
    With ws.Shapes.AddLine(x1, y1, x1, yf).Line     ' father to horizontal line
        .DashStyle = msoLineSolid
        .ForeColor.RGB = RGB(50, 40, 130):    .Weight = 2
    End With
    For i = 2 To Range("n" & Rows.Count).End(xlUp).Row                       ' sons to horizontal line
        Set r = Range("v:v").Find(Cells(i, "n").Value, [v1], xlValues, xlWhole)
        x1 = r.Offset(, -1) + r.Offset(, 3) / 2
        With ws.Shapes.AddLine(x1, r.Offset(, -2) + r.Offset(, 1), x1, yf).Line
            .DashStyle = msoLineSolid
            .ForeColor.RGB = RGB(50, 40, 130)
            .Weight = 2
        End With
    Next
    End If
    End If
Next
On Error Resume Next
For i = 1 To ws.Shapes.Count
    If Not ws.Shapes(i).TextFrame2.TextRange.Text Like "*%*" Then _
    ws.Shapes(i).TextFrame2.TextRange.Font.Size = 16
Next
On Error GoTo 0
End Sub

Sub Phase1()                                            ' draw original chart
Dim arr(), i%, t
arr = Range([a1].CurrentRegion.Address)                 ' save original table
[ca:ce].ClearContents
Adjust
CreateDiagram ActiveSheet, 1.6
[a:p].ClearContents
[a1].Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr ' original table
On Error Resume Next
For i = 1 To ActiveSheet.Shapes.Count
    If ActiveSheet.Shapes(i).TopLeftCell = [a1] Then ActiveSheet.Shapes(i).Delete
    t = ActiveSheet.Shapes(i).TextFrame2.TextRange.Text
    If Len(t) And Not t Like "*%*" Then ActiveSheet.Shapes(i).IncrementRotation 180
Next
On Error GoTo 0
End Sub

Sub Phase2(move As Boolean, geo As Boolean)                 ' increases vertical spacing
Dim ws As Worksheet, i%, s As Shape, r As Range, lr%, delta, v%, sn As Shape, dt As Worksheet, x, boss$
Set dt = Sheets("tdata"): Set ws = Sheets("final")
dt.Activate: dt.Cells.ClearContents
Set r = [a75]
On Error Resume Next
For Each s In ws.Shapes
    If Len(s.TextFrame2.TextRange.Text) = 0 Then s.Delete   ' connectors
Next
On Error GoTo 0
[a74] = "name": [b74] = "top": [c74] = "left": [d74] = "text": [e74] = "height"
[h74] = "top": [f74] = "level": [g74] = "width"
For i = 1 To ws.Shapes.Count
    If Not ws.Shapes(i).Name Like "*aux*" Then
        r = ws.Shapes(i).Name
        r.Offset(, 1) = Round(ws.Shapes(i).Top, 0)
        r.Offset(, 2) = Round(ws.Shapes(i).Left, 0)
        r.Offset(, 3) = Split(ws.Shapes(i).TextFrame2.TextRange.Text, vbLf)(0)
        r.Offset(, 4) = Round(ws.Shapes(i).Height, 0)
        r.Offset(, 6) = Round(ws.Shapes(i).Width, 0)
        Set r = r.Offset(1)
    End If
Next
lr = Range("b" & Rows.Count).End(xlUp).Row
Range("B74:B" & lr).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=[h74:h75], _
CopyToRange:=[i74], Unique:=True
Sorter "i", 75, dt
Range("j75:j" & lr).Formula = "=row()-74"
lr = Range("b" & Rows.Count).End(xlUp).Row
Range("f75:f" & lr).Formula = "=match(b75,$i$75:$i$" & lr & ",0)"  ' level
If move Then
    delta = WorksheetFunction.Max([e:e])
    For i = 75 To lr
        Set sn = ws.Shapes(Range("a" & i))
        sn.Height = h
        sn.Width = w
        sn.Top = 2000 - delta * Range("f" & i) * 2              ' new vertical position
    Next
End If
Set r = Range("f1:f" & lr).Find(1, [f1], xlValues, xlWhole)     ' big boss
boss = r.Offset(, -5)
On Error Resume Next
ws.Shapes(boss & "aux").Delete
On Error GoTo 0
[h75] = 2                                                      'level 2
[h74] = [f74]
Range("a74:g" & lr).AdvancedFilter xlFilterCopy, [h74:h75], [L74], False
If geo And move Then                                                     ' geometric middle
    x = WorksheetFunction.Max([n:n]) - WorksheetFunction.Min([n:n]) + WorksheetFunction.Max([r:r])
    ws.Shapes(boss).Left = WorksheetFunction.Min([n:n]) + x / 2 - WorksheetFunction.Max([r:r]) / 2
ElseIf move And Not geo Then                                             ' align to nearest shape
    lr = Range("L" & Rows.Count).End(xlUp).Row
    Range("s75:s" & lr).Formula = "=abs(n75-" & CInt(ws.Shapes(boss).Left) & ")"
    Range("t75:t" & lr).Formula = "=$n75"
    Set r = Range("s:s").Find(WorksheetFunction.Min([s:s]), [s1], xlValues, xlWhole)
    ws.Shapes(boss).Left = r.Offset(, 1)
End If
End Sub

Sub Sorter(col$, rn%, dt As Worksheet)
Dim lr%
lr = dt.Range(col & Rows.Count).End(xlUp).Row
dt.Sort.SortFields.Clear
dt.Sort.SortFields.Add Key:=dt.Cells(rn, col), SortOn:=xlSortOnValues, _
Order:=2, DataOption:=0
With dt.Sort
    .SetRange dt.Range(dt.Cells(rn, col), dt.Cells(lr, col))
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
End Sub

Sub Adjust()
Dim lr%, i%
For i = 1 To ActiveSheet.Shapes.Count
    ActiveSheet.Shapes(1).Delete
Next
[k:ae].ClearContents
lr = Range("a" & Rows.Count).End(xlUp).Row
[k1] = "Seq": [L1] = "code1": [m1] = "code2"
[L2] = [b2]: [n1] = "info": [o1] = "info2": [p1] = "outline"
[m2] = [b2]: [k2] = 2: [n2] = 0.01: [o2] = "desc0"
Range("a2:a" & lr).Copy
[L3].PasteSpecial xlPasteAll
Range("b2:b" & lr).Copy
Range("m3").PasteSpecial xlPasteAll
Range("c2:c" & lr).Copy
Range("o3").PasteSpecial xlPasteAll
Range("d2:d" & lr).Copy
Range("n3").PasteSpecial xlPasteAll
Range("e2:e" & lr).Copy
Range("p3").PasteSpecial xlPasteAll
Range("k3:k" & lr + 1).Formula = "=row()"
[a:e].ClearContents
[k1].CurrentRegion.Copy [a1]                    ' adjusted table
[L2].Interior.Color = RGB(35, 70, 90)
[k1].CurrentRegion.Copy [z100]
End Sub

Sub CreateDiagram(Src As Worksheet, factor#)
Dim sal As SmartArtLayout, QNode As SmartArtNode, QNodes As SmartArtNodes, oshp As Shape, L%, _
i%, r As Range, PID$, mn, mx, ws As Worksheet, crar(), c%, ad, v, t, s As ShapeRange, boss
c = 1
ReDim crar(1 To c)
Set ws = ActiveSheet
For i = 1 To ws.Shapes.Count
    ws.Shapes(1).Delete
Next
Select Case Val(Application.Version)
    Case 15                                 ' Excel 2013
        Set sal = Application.SmartArtLayouts(89)
        Set oshp = ws.Shapes.AddSmartArt(sal)
    Case 16                                 ' Excel 2016
        Set oshp = ActiveSheet.Shapes.AddSmartArt(Application.SmartArtLayouts _
        ("urn:microsoft.com/office/officeart/2008/layout/NameandTitleOrganizationalChart"))
End Select
oshp.Top = [a50].Top
Set QNodes = oshp.SmartArt.AllNodes
For i = 1 To 5
    oshp.SmartArt.AllNodes(1).Delete        ' initial nodes
Next
L = 2                                       ' look for roots
boss = [b2]
Do While Src.Cells(L, 1) <> ""
    If Src.Cells(L, 2) = Src.Cells(L, 3) Then
        Set QNode = oshp.SmartArt.AllNodes.Add
        QNode.TextFrame2.TextRange.Text = Src.Cells(L, 2)
        PID = Src.Cells(L, 2)              ' parent node
        Src.Rows(L).Delete
        AddChildNodes QNode, Src, PID
    Else
        L = L + 1
    End If
Loop
oshp.SmartArt.AllNodes(1).TextFrame2.TextRange.Text = boss
oshp.Width = 1000
oshp.Height = 700
oshp.Select
CommandBars.ExecuteMso ("SmartArtConvertToShapes")
With Selection
    .ShapeRange.IncrementRotation 180
    .ShapeRange.ScaleWidth factor, msoFalse, msoScaleFromBottomRight       ' overall size
    .ShapeRange.ScaleHeight factor, msoFalse, msoScaleFromBottomRight
    .Ungroup
End With
Set r = ws.[A2]
On Error Resume Next
For i = 1 To ws.Shapes.Count
    r = ws.Shapes(i).Height
    Set r = r.Offset(1)
Next
mn = WorksheetFunction.Min([a:a])
mx = WorksheetFunction.Max([a:a])
For i = ws.Shapes.Count To 1 Step -1
    If ws.Shapes(i).Height = mn Then ws.Shapes(i).Delete
    If ws.Shapes(i).Height = mx Then
        crar(c) = ws.Shapes(i).Name
        c = c + 1
        ReDim Preserve crar(1 To c)
    End If
Next
On Error GoTo 0
For i = LBound(crar) To UBound(crar)
    If Len(crar(i)) Then
        v = Split(ws.Shapes(crar(i)).TextFrame2.TextRange.Text, vbLf)(0)
        Set r = Range("aa:aa").Find(v, [aa1], xlValues, 1)
        ad = r.Offset(, 2)
        ws.Shapes(crar(i)).Fill.ForeColor.RGB = r.Interior.Color
        Set s = ws.Shapes.Range(Array(crar(i)))
        s.TextFrame2.TextRange.Font.Bold = msoTrue
        s.TextFrame2.TextRange.Font.Name = "+mj-lt"
        If r.Offset(, 4) = "O" Then                 ' outline
            With s.Line
                .Weight = 4
                .Visible = msoTrue
                .ForeColor.RGB = RGB(200, 25, 55)
                .Transparency = 0.1
            End With
        End If
    End If
Next
End Sub

Sub AddChildNodes(QNode As SmartArtNode, Source As Worksheet, PID$)
Dim L%, Found As Boolean, ParNode As SmartArtNode, CurPid$, ad
L = 2
Found = False                           'nothing found yet
Do While Source.Cells(L, 1) <> ""
    If Source.Cells(L, 3) = PID Then
        Set ParNode = QNode
        Set QNode = QNode.AddNode(msoSmartArtNodeBelow)
        QNode.TextFrame2.TextRange.Text = Cells(L, 2) & vbLf & Cells(L, 5)
        CurPid = Source.Cells(L, 2)     ' current parent node
        If Not Found Then Found = True  'something was found
        Source.Rows(L).Delete
        AddChildNodes QNode, Source, CurPid
        Set QNode = ParNode
        ElseIf Found Then               'it's sorted, nothing else can be found
        Exit Do
    Else
        L = L + 1
    End If
Loop
End Sub

Sub GroupShapes(tp As Boolean)
Dim ws As Worksheet
If tp Then
    Set ws = Sheets("final")
    ws.Activate
    ws.Shapes.SelectAll
    Selection.Group
    Selection.ShapeRange.IncrementRotation 180
    DoEvents
    ws.Shapes(1).IncrementRotation 180
End If
ws.Shapes(1).Ungroup
End Sub

Sub Tog()
Dim s As Shape, dtr, bol, i%
Set s = ActiveSheet.Shapes(1)
dtr = IIf(s.GroupItems(parr(2)).Fill.Transparency = 0.99, 0, 0.99)
bol = IIf(dtr = 0, msoTrue, msoFalse)
For i = 1 To UBound(parr) - 1
    s.GroupItems(parr(i)).Fill.Transparency = dtr
    s.GroupItems(parr(i)).Line.Visible = bol
Next
End Sub

Sub Horiz()
Dim lr%, i%, c%, j%, fs As Worksheet
Set fs = Worksheets("final")
Application.CutCopyMode = False
lr = Split([a74].CurrentRegion.Address, "$")(4)
[n86] = "level"
For j = 2 To WorksheetFunction.Max(Sheets("tdata").[f:f])
    [n87] = j
    [q150].CurrentRegion.Delete
    Range("A74:G" & lr).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range _
    ("N86:N87"), CopyToRange:=Range("Q150:W150"), Unique:=False
    [x150] = "newleft"
    lr = Split([q150].CurrentRegion.Address, "$")(4)
    For i = 151 To lr
        Cells(i, "x") = fs.Shapes(Cells(i, 17)).Left
    Next
    SortMult lr
    c = 150
    Do While c < 250 And WorksheetFunction.IsNumber(Cells(c, "x"))
        If Cells(c, "x") + Cells(c, 23) > Cells(c + 1, "x") Then _
        Cells(c + 1, "x") = Cells(c, "x") + Cells(c, 23) + 10
        c = c + 1
    Loop
    c = 150
    Do While c < 250 And WorksheetFunction.IsNumber(Cells(c, "x"))
        fs.Shapes(Cells(c, "q")).Left = Cells(c, "x")
        c = c + 1
    Loop
Next
On Error Resume Next
For i = 1 To fs.Shapes.Count
    If Not fs.Shapes(i).TextFrame2.TextRange.Text Like "*%*" Then _
    fs.Shapes(i).TextFrame2.TextRange.Font.Size = 16
Next
On Error GoTo 0
End Sub

Sub SortMult(lr%)
dt.Sort.SortFields.Clear
dt.Sort.SortFields.Add2 Key:=Range( _
"X150:X" & lr), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=0
With dt.Sort
    .SetRange Range("Q150:X" & lr)
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = 1
    .Apply
End With
End Sub
'
Function Chain(parent$, child$, Optional arr)
Dim comb$, i&, ret()
comb = parent & "|" & child
If Not dictC.Exists(comb) Then
    ReDim ret(1 To UBound(arr) + 1)
    For i = 1 To UBound(ret)
        If i < 3 Then
        ret(i) = arr(i)
        ElseIf i = 3 Then
            If dictA.Exists(parent) Then
                ret(i) = dictA(parent)
            Else
                ret(i) = "top"
            End If
        Else
        ret(i) = arr(i - 1)
        End If
    Next
    If dictA.Exists(parent) Then
        Chain = Chain(dictA(parent), dictA(parent), ret)
    Else 'end of the line
        Chain = ret
    End If
Else
    ReDim ret(1 To 4)
    ret(1) = parent: ret(2) = child
    ret(3) = parent
    ret(4) = child
    If parent = "top" Then
        Chain = ret 'end of the line
    Else
        Chain = Chain(parent, parent, ret)
    End If
End If
End Function

Sub Expand()
Dim child$, parent$, comb$, ws As Worksheet, lRow&, amt&, i&, j&, arr(), part, all, maxLvl&
lRow = Sheets("source").Range("A" & Rows.Count).End(xlUp).Row
Set dictA = New Dictionary: Set dictC = New Dictionary
arr = ThisWorkbook.Sheets("source").Range("A2:B" & lRow).Value
amt = UBound(arr, 1)
For i = 1 To amt
    If Not arr(i, 1) = "top" Then
        If Not dictA.Exists(arr(i, 2)) Then dictA.Add arr(i, 2), arr(i, 1)
    End If
Next
For i = 1 To amt
    comb = arr(i, 1) & "|" & arr(i, 2)
    If Not dictC.Exists(comb) Then dictC.Add comb, arr(i, 1)
Next
maxLvl = 2
ReDim all(1 To amt, 1 To amt - 1) 'absolute max
For i = 1 To UBound(arr, 1)
    parent = arr(i, 1): child = arr(i, 2)
    part = Chain(parent, child)
    If UBound(part) > maxLvl Then maxLvl = UBound(part)
    For j = 1 To UBound(part)
        all(i, j) = part(j)
    Next
Next
ReDim Preserve all(1 To amt, 1 To maxLvl)
Set ws = ThisWorkbook.Sheets("sheet3")
With ws
    .[a1].Value = "Parent": .[b1].Value = "Child"
    For i = 1 To maxLvl - 2 'adjust to the starting parent/child
        .Cells(1, i + 2) = "Level " & i
    Next
    .[A2].Resize(UBound(all, 1), UBound(all, 2)).Value = all
End With
Set dictA = Nothing: Set dictC = Nothing
End Sub

Sub preparation()
Dim c As Range, i, j%, n, k, store(), lr%, s3 As Worksheet, pr%, m%, d As Range, _
orig As Worksheet, fin As Worksheet, sou As Worksheet
Set orig = Sheets("original")
Set s3 = Sheets("sheet3")
Set fin = Sheets("final")
Set sou = Sheets("source")
sou.[a:m].ClearContents
s3.[a:i].ClearContents
fin.[a:b].ClearContents
orig.[aa:ac].ClearContents
orig.Activate
lr = Evaluate("=SUMPRODUCT(MAX(ROW(y:y)*(y:y<>"""")))")
orig.[y:y].AdvancedFilter Action:=xlFilterCopy, CopyToRange:=orig.Range("ab30"), Unique:=True
orig.[z:z].AdvancedFilter Action:=xlFilterCopy, CopyToRange:=orig.Range("ad30"), Unique:=True
orig.Range("y30").CurrentRegion.Copy sou.[a1]
orig.[aa30] = "number of parents"
orig.Range("aa31").FormulaR1C1 = "=COUNTIF(C[-1],RC[-1])"
[aa31].AutoFill Destination:=Range("aa31:aa" & lr), Type:=xlFillDefault
orig.[ab30] = "multiple parents"
orig.[ab31].FormulaR1C1 = "=if(rc[-1]>1,rc[-2],"""")"
[ab31].AutoFill Destination:=Range("ab31:ab" & lr), Type:=xlFillDefault
orig.Range("ab30:ab" & lr).AdvancedFilter xlFilterCopy, , orig.[ac30], True
sou.Activate
Range("B1:B60").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("K1"), Unique:=True
j = 0
lr = Evaluate("=SUMPRODUCT(MAX(ROW(k:k)*(k:k<>"""")))")
Range("L3").FormulaR1C1 = "=COUNTIF(C[-10],RC[-1])"
[L3].AutoFill Destination:=Range("L3:L" & lr), Type:=xlFillDefault
For i = 2 To lr
    If Cells(i, "L") > 1 Then
        n = Cells(i, "L")
        Set c = Nothing
        For k = 1 To n - 1
            j = j + 1
            If c Is Nothing Then Set c = [b:b].Find(Cells(i, "k"), LookIn:=xlValues)
            ReDim Preserve store(1 To j)
            store(j) = c.Offset(, -1) & "/" & c.Value
            c = "dummy" & j
            Set c = [b:b].FindNext(c)
        Next
    End If
Next
Expand
s3.Activate
pr = Evaluate("=sumproduct(max(row(a:a)*(a:a<>"""")))")
s3.Range("a2:a" & pr).AdvancedFilter xlFilterCopy, , s3.[m40], True
For m = 40 To Evaluate("=sumproduct(max(row(m:m)*(m:m<>"""")))")
    Set c = [b:b].Find(s3.Cells(m, "m"), LookIn:=xlValues)
    If Not c Is Nothing Then
        'MsgBox
    Else
        Set d = s3.Range(Cells(1, 3), Cells(50, s3.[a1].CurrentRegion.Columns.Count)).Find(s3.Cells(m, "m"), , xlValues)
        s3.[A2].EntireRow.Insert
        s3.[A2] = d.Offset(, -1)
        s3.[b2] = d
    End If
Next
s3.[a2:a50].Copy fin.[b2]
s3.[b2:b50].Copy fin.[A2]
fin.[a1] = "son": fin.[b1] = "father"
main
End Sub