Organization Chart with VBA – Part 4

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

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
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
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
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%
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
    [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
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("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(, 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
Rem         ws.Shapes(Range("a" & i) & "aux").Top = sn.Top + sn.Height
    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("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
'******************

Option Explicit

Dim td As Worksheet, fs As Worksheet

Private Sub ComboBox1_Change()
Dim res As Range, br%, lett$
Set res = td.Range("74:74").Find(Me.ComboBox1.Value, , xlValues, xlWhole)
lett = Split(res.Address, "$")(1)
br = Split(td.[v74].CurrentRegion.Address, "$")(4)
Me.ListBox1.RowSource = td.Range(lett & "75:" & lett & br).Address(, , , True)
End Sub

Private Sub ComboBox2_Change()
Dim res As Range, br%, lett$
Set res = td.Range("74:74").Find(Me.ComboBox2.Value, , xlValues, xlWhole)
lett = Split(res.Address, "$")(1)
br = Split(td.[v74].CurrentRegion.Address, "$")(4)
Me.ListBox2.RowSource = td.Range(lett & "75:" & lett & br).Address(, , , True)
End Sub

Private Sub ComboBox3_Change()
Dim res As Range, br%, lett$
Set res = td.Range("74:74").Find(Me.ComboBox3.Value, , xlValues, xlWhole)
lett = Split(res.Address, "$")(1)
br = Split(td.[v74].CurrentRegion.Address, "$")(4)
Me.ListBox3.RowSource = td.Range(lett & "75:" & lett & br).Address(, , , True)
End Sub

Private Sub CommandButton1_Click()
Dim am%, nam$, res As Range, lr%, i%
Rem move shape
If (Me.TextBox1.Text) = "" Then
    MsgBox "Inform distance", vbCritical
    Exit Sub
End If
am = IIf(Me.OptionButton3.Value, CDbl(Me.TextBox1.Text), -CDbl(Me.TextBox1.Text))
If IsNull(Me.ListBox1.Value) And Me.OptionButton2.Value Then
    MsgBox "Select a child", vbCritical
    Exit Sub
End If
nam = IIf(Me.OptionButton1.Value, Me.ComboBox1.Value, Me.ListBox1.Value)
lr = Split(td.[a74].CurrentRegion.Address, "$")(4)
Set res = td.Range("d74:d" & lr).Find(nam, , xlValues, xlWhole)
fs.Shapes(res.Offset(, -3)).Left = fs.Shapes(res.Offset(, -3)).Left + am
If Me.OptionButton9.Value Then
    For i = LBound(Me.ListBox1.List) To UBound(Me.ListBox1.List)
        If Len(Me.ListBox1.List(i)) Then
            nam = Me.ListBox1.List(i)
            Set res = td.Range("d74:d" & lr).Find(nam, , xlValues, xlWhole)
            fs.Shapes(res.Offset(, -3)).Left = fs.Shapes(res.Offset(, -3)).Left + am
        End If
    Next
End If
End Sub

Private Sub CommandButton2_Click()
Rem swap
Dim old%(1 To 2), nam$, lr%, res(1 To 2) As Range
nam = IIf(Me.OptionButton5.Value, Me.ComboBox2.Value, Me.ListBox2.Value)
lr = Split(td.[a74].CurrentRegion.Address, "$")(4)
Set res(1) = td.Range("d74:d" & lr).Find(nam, , xlValues, xlWhole)
old(1) = fs.Shapes(res(1).Offset(, -3)).Left
nam = IIf(Me.OptionButton7.Value, Me.ComboBox3.Value, Me.ListBox3.Value)
Set res(2) = td.Range("d74:d" & lr).Find(nam, , xlValues, xlWhole)
old(2) = fs.Shapes(res(2).Offset(, -3)).Left
fs.Shapes(res(1).Offset(, -3)).Left = old(2)
fs.Shapes(res(2).Offset(, -3)).Left = old(1)
End Sub

Private Sub CommandButton3_Click()
Rem center children
Dim cw%, n%, i%, res As Range, lr%, lc%
For i = LBound(Me.ListBox1.List) To UBound(Me.ListBox1.List)
    If Len(Me.ListBox1.List(i)) = 0 Then
        n = i
        Exit For
    End If
Next
If i = UBound(Me.ListBox1.List) + 1 Then n = i
If Me.TextBox2.Value = "" Then
    MsgBox "Inform spacing", vbCritical
    Exit Sub
End If
lr = Split(td.[a74].CurrentRegion.Address, "$")(4)
td.Cells(75, 7) = fs.Shapes(td.Cells(75, 1)).Width
cw = n * td.[g75] + (n - 1) * CDbl(Me.TextBox2.Value)
Set res = td.Range("d74:d" & lr).Find(Me.ComboBox1.Value, , xlValues, xlWhole)
lc = fs.Shapes(res.Offset(, -3)).Left + (td.[g75] / 2) - (cw / 2)
For i = LBound(Me.ListBox1.List) To UBound(Me.ListBox1.List)
    If Me.ListBox1.List(i) = Empty Then Exit For
    Set res = td.Range("d74:d" & lr).Find(Me.ListBox1.List(i), , xlValues, xlWhole)
    fs.Shapes(res.Offset(, -3)).Left = lc
    lc = lc + td.[g75] + CDbl(Me.TextBox2.Value)
Next
End Sub

Private Sub CommandButton4_Click()
Rem draw connectors
Dim i%, lr%
lr = Split(td.[a74].CurrentRegion.Address, "$")(4)
For i = 75 To lr
    td.Cells(i, 3) = fs.Shapes(td.Cells(i, 1)).Left
    td.Cells(i, 2) = fs.Shapes(td.Cells(i, 1)).Top
    td.Cells(i, 7) = fs.Shapes(td.Cells(i, 1)).Width
Next
lr = td.Range("b" & Rows.Count).End(xlUp).Row
td.Range("B74:B" & lr).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=td.[h74:h75], _
CopyToRange:=td.[i74], Unique:=True
Sorter "i", 75, td
Phase3
End Sub

Private Sub UserForm_Click()
Dim j%
For j = LBound(Me.ListBox1.List) To UBound(Me.ListBox1.List)
    MsgBox Me.ListBox1.List(j)
Next
End Sub

Private Sub UserForm_Initialize()
Dim lcol
Set td = Worksheets("tdata")
Set fs = Worksheets("fshap")
fs.[h1:r30].ClearContents
td.[t60:ac110].ClearContents
RefList
lcol = Split(td.[v74].CurrentRegion.Address, "$")(3)
Me.OptionButton1.Value = True
Me.OptionButton3.Value = True
Me.ComboBox1.List = WorksheetFunction.Transpose(td.Range("v74:" & lcol & "74").Value)
Me.ComboBox2.List = WorksheetFunction.Transpose(td.Range("v74:" & lcol & "74").Value)
Me.ComboBox3.List = WorksheetFunction.Transpose(td.Range("v74:" & lcol & "74").Value)
End Sub