Organization Chart with VBA – Part 6

Option Explicit
Dim fs As Worksheet, h%, w%, parr, dt As Worksheet, dicta As Dictionary, dictc As Dictionary

Sub Tray()
Dim i%, ws As Worksheet, s$, dest As Worksheet, arr, src As Worksheet, exp As Worksheet
Set exp = Sheets("sheet3"): Set src = Sheets("source")
arr = Array("son", "father", "description")
Set dest = Sheets("fshap")
Set ws = Sheets("project")
dest.[a1:c1] = arr
For i = 1 To ws.[b25]
    s = Replace(ws.Cells(i + 9, 3), ".", "")
    Select Case Len(s)
        Case 1
        dest.Cells(i + 1, 2) = "top"
        dest.Cells(i + 1, 1).Formula = "=text(" & s & ",""0000"")"
        dest.Cells(i + 1, 3) = ws.Cells(i + 9, 4)
        Case Is > 1
        dest.Cells(i + 1, 2).Formula = "=text(" & Mid(s, 1, Len(s) - 1) & ",""0000"")"
        dest.Cells(i + 1, 1).Formula = "=text(" & s & ",""0000"")"
        dest.Cells(i + 1, 3) = ws.Cells(i + 9, 4)
    End Select
    Select Case Mid(s, 1, 1)
        Case 1
        If Len(s) < 4 Then
        dest.Cells(i + 1, 1).Interior.Color = RGB(10, 200, 20)
        Else
        dest.Cells(i + 1, 1).Interior.Color = RGB(200, 50, 150)
        End If
        Case 2
        dest.Cells(i + 1, 1).Interior.Color = RGB(100, 5, 50)
    End Select
Next
src.[a1:b100].ClearContents
dest.[a2:a50].Copy src.[b2]
dest.[b2:b50].Copy src.[a2]
Main
End Sub

Sub CreateCol()
Dim r As Range, clm, Lr, i, j, el, k, Lr2, ec() As New Collection, v, arr(), _
g As Shape, gs$, gsheet As Worksheet, fs As Worksheet
Set fs = Sheets("fshap")
Sheets("sheet3").Activate
Lr = Cells(Range("d:d").Rows.Count, 4).End(xlUp).Row
[j1] = [d1]
Range("d1:d" & Lr).AdvancedFilter xlFilterCopy, Range("j1:j2"), [L30], True
Lr2 = Cells(Range("L:L").Rows.Count, "L").End(xlUp).Row
For k = 2 To Lr
    Cells(k, 4).Formula = "=text(" & Cells(k, 4).Value & ",""0000"")"
Next
ReDim ec(1 To (Lr2 - 30))
For k = 31 To Lr2
     Cells(k, "L").Formula = "=text(" & Cells(k, "L").Value & ",""0000"")"
   ec(k - 30).Add Cells(k, "L"), Cells(k, "L")
        If Len(Cells(k, "L")) Then
        For i = 2 To Lr
            If Len(Cells(i, 4)) And Cells(i, 4) = Cells(k, "L") Then
                On Error Resume Next
                For j = 5 To Cells(i, ActiveSheet.Columns.Count).End(xlToLeft).Column
                    If Len(Cells(i, j)) Then
                    Cells(i, j).Formula = "=text(" & Cells(i, j).Value & ",""0000"")"
                    ec(k - 30).Add Cells(i, j).Value, Cells(i, j).Value
                    End If
                Next
                On Error GoTo 0
            End If
        Next
    End If
Next
For k = 1 To (Lr2 - 30)
    ReDim arr(1 To 1)
    j = 0
    For i = 1 To fs.Shapes.Count
        v = Split(fs.Shapes(i).Name, vbLf)(0)
        If v Like "conn*" Then v = Mid(v, 5, Len(v) - 5)
        If Exists(ec(k), CStr(v)) Then
            j = j + 1
            ReDim Preserve arr(1 To j)
            arr(j) = i
        End If
    Next
    gs = "group" & CStr(k)
    fs.Activate
    Set g = ActiveSheet.Shapes.Range(arr).Group
    DoEvents
    If Not SheetExists(gs) Then
        Set gsheet = Sheets.Add
        gsheet.Name = gs
    End If
    g.Copy: Sheets(gs).Paste
Next
fs.Shapes("top").Delete
End Sub

Function SheetExists(sh$) As Boolean
Dim ws As Worksheet
SheetExists = False
On Error Resume Next
Set ws = ThisWorkbook.Sheets(sh)
On Error GoTo 0
If Not ws Is Nothing Then SheetExists = True
End Function

Function Exists(c As Collection, key$) As Boolean
On Error GoTo EH
IsObject (c.Item(key))
Exists = True
EH:
End Function

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:u100].ClearContents
    .[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 RefList()
Dim Lr%, lastcell As Range, lc%, r%
Set fs = Sheets("fshap")
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 RecPic()
Dim s As Shape, r As Range, i, mydocument, ss As Shape, v, rf As Range, _
shr As ShapeRange, ish As Shape, picsh As Shape, j%, Lr%
Set r = [an1]
Lr = Cells(Rows.Count, 1).End(xlUp).Row
ReDim parr(1 To Lr)
Set s = ActiveSheet.Shapes(1)
v = Split([as3].Value, Chr(10))
j = 1
If ActiveSheet.Shapes.Count = 1 Then s.Ungroup
DoEvents
For i = 1 To ActiveSheet.Shapes.Count
    Set ish = ActiveSheet.Shapes(i)
    If ish.Name Like "Freeform*" And (Not ish.Name Like "*aux*") Then
        If ish.TextFrame2.TextRange.Text <> [b2] Then
            Set ss = ActiveSheet.Shapes.AddShape(msoShapeRectangle, ish.Left + 1, _
            ish.Top + ish.Height / 2, ish.Width - 2, ish.Height / 2)
            ss.Left = ish.Left
            Set picsh = ActiveSheet.Shapes.AddShape(1, ish.Left, ish.Top, ish.Width / 2.5, ish.Height)
            parr(j) = picsh.Name
            j = j + 1
        End If
        v = Split(ish.TextFrame2.TextRange.Text, Chr(10))
        If UBound(v) Then
            ss.TextFrame2.TextRange.Text = v(1)
            ss.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
            ss.Top = ish.Top + ish.Height / 2
            ss.Left = ish.Left + 1
        End If
        If UBound(v) Then
            Set rf = Range("c:c").Find(v(1), LookIn:=xlValues)
            ss.Fill.ForeColor.RGB = rf.Interior.Color
            picsh.Fill.UserPicture "c:\test\" & Cells(rf.Row, 6) & ".png"
            picsh.Fill.Visible = msoTrue
            picsh.Fill.Transparency = 0.99
            picsh.Line.Visible = msoFalse
        End If
    End If
Next
ActiveSheet.Shapes.SelectAll
Selection.Group
End Sub

Sub Main()                                                  ' run me
Dim i%, ob As Worksheet, r As Range, tb As Shape
Set dt = Sheets("tdata")
Set ob = Sheets("fshap")
h = 1
w = 1
ob.[h:k].ClearContents
ob.[p:p].ColumnWidth = 3 + Round(Rnd(3))
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("secdata").[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
On Error Resume Next
For i = ob.Shapes.Count To 1 Step -1
   ob.Shapes(i).Name = ob.Shapes(i).TextFrame2.TextRange.Text
Next
On Error GoTo 0
Phase2 True, False                                            ' move shapes
Phase2 False, False                                           ' update table
Horiz
Sheets("secdata").[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
GroupShapes True                                                ' top to bottom
ob.Shapes(1).Ungroup
MsgBox ob.Shapes.Count, , "shape count"
For i = 1 To ob.Shapes.Count
If Not ob.Shapes(i).TextFrame2.TextRange.Text Like "*%*" Then _
    ob.Shapes(i).TextFrame2.TextRange.Font.Size = 16
Next
DoEvents
ob.[y:ag].ClearContents
ob.[y:ag].Interior.Color = RGB(250, 250, 250)

Rem RecPic                                                          ' two colours per box
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%, L As Shape, a
Set ws = Sheets("fshap")
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 = 2 To Range("k" & Rows.Count).End(xlUp).Row
If Cells(j, "k") <> "top" 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
    [ac:ac].ColumnWidth = 3 + Round(Rnd(2), 0)
    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)
    
    Set L = ws.Shapes.AddLine(x1, yf, x2, yf)                             ' horizontal
        L.Line.DashStyle = msoLineSolid
        L.Line.ForeColor.RGB = RGB(50, 40, 130)
        L.Line.Weight = 2
        L.Name = "conn" & [m2] & "h"
    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 Not WorksheetFunction.IsErr(r.Offset(, -2)) Then
    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
    End If
        Set L = ws.Shapes.AddConnector(msoConnectorStraight, x1, y1, x1, yf)
    L.ConnectorFormat.BeginConnect ws.Shapes([s2]), 1           'reset the drawing engine
    L.Delete
    Set L = ws.Shapes.AddLine(x1, y1, x1, yf)    ' father to horizontal line
        L.Line.DashStyle = msoLineSolid
        L.Line.ForeColor.RGB = RGB(50, 40, 130):    L.Line.Weight = 2
        L.Name = "conn" & [m2] & "f"
      
    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
        Set L = ws.Shapes.AddLine(x1, r.Offset(, -2), x1, yf)
            L.Line.DashStyle = msoLineSolid
            L.Line.ForeColor.RGB = RGB(50, 40, 130)
            L.Line.Weight = 2
            L.Name = "conn" & Cells(i, "n").Value & "s"
    Next
End If
Next
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("fshap")
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(, 3).Formula = "=text(" & r.Offset(, 3) & ",""0000"")"
        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, src As Worksheet, PID$)
Dim L%, Found As Boolean, ParNode As SmartArtNode, CurPid$, ad
L = 2
Found = False                           'nothing found yet
Do While src.Cells(L, 1) <> ""
    If src.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 = src.Cells(L, 2)     ' current parent node
        If Not Found Then Found = True  'something was found
        src.Rows(L).Delete
        AddChildNodes QNode, src, 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("fshap")
    ws.Activate
    ws.Shapes.SelectAll
    Selection.Group
    Selection.ShapeRange.IncrementRotation 180
    DoEvents
    ws.Shapes(1).IncrementRotation 180
End If
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("fshap")
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
'******************