• If you would like to post, please check out the MrExcel Message Board FAQ and register here. If you forgot your password, you can reset your password.
  • Excel articles and downloadable files provided in the articles have not been reviewed by MrExcel Publishing. Please apply the provided methods / codes and open the files at your own risk. If you have any questions regarding an article, please use the Article Discussion section.
Worf

Organization Chart with VBA – Part 4

Excel Version
  1. 2016
A request came up to accommodate wide boxes. Since it would be complicated to modify the core algorithm, I opted to prepare an interface where the user will be able to adjust the chart to their liking.

You will be presented with a basic chart without connectors; bring up the user form and arrange the boxes using the available options. When everything is ready, add the connectors.

Here is a more detailed description:

  • Run the main routine to create the chart
  • Run the user form routine to display it. The form is modeless, meaning you can access the worksheet without closing it.
  • At the move page, choose a parent at the combo box to see the corresponding children. You can adjust the horizontal positioning of the parent or a child by informing the offset in points, 20 is a good value to start with. It is possible to move the children together with the parent. It is also possible to centre the children relative to the parent, again informing the distance between them in the textbox.
  • At the swap page you can exchange positions of two boxes in the same vertical level. Use the right and left sides to pick the two boxes. Note that it is necessary to select a child on the list, if it is the case of swapping it.
  • After you are done, go to the finish page and click the button to draw the connectors.
  • One issue with wide boxes is that in order to view the entire diagram at once, it is often hard to read the text inside the boxes…
wide org.png


uform.png


Org_3_aug.xlsm
ABCDEF
1sonfatherdescriptiondescription2outlinePicture
2GRANDDADTOP_PERSONdesc1100%pic1
3GRANDMATOP_PERSONdesc2100%pic2
4DADGRANDDADdesc3100%pic3
5MAGRANDDADdesc4100%Opic4
6CHILD100MAdesc5100%pic5
7CHILD101MAdesc6100%pic1
8CHILD102MAdesc7100%pic2
9CHILD103MAdesc80.8Opic3
10CHILD1DADdesc90.8pic4
11CHILD2DADdesc100.8pic5
12CHILD3DADdesc110.8Opic1
13CHILD4DADdesc120.8pic2
14CHILD5DADdesc130.8pic3
15DOG01CHILD100desc14100%Opic4
16DOG02CHILD100desc15100%pic5
17DOG03CHILD100desc16100%pic1
18DOG04CHILD100desc17100%pic2
19DOG05CHILD100desc18100%pic3
20BIRD01CHILD103desc190.6pic4
21BIRD02CHILD103desc200.6Opic5
22BIRD03CHILD103desc210.6pic4
23CAT1CHILD5desc220.6pic3
24CAT2CHILD5desc extra super long10.6pic2
25CAT3CHILD5desc extra super long2100%pic1
26CAT4CHILD5desc extra super long3100%pic2
27CAT5CHILD5desc extra super long4100%pic3
28CAT6CHILD5desc extra super long50.9pic4
fshap



VBA Code:
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
'******************

VBA Code:
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
Author
Worf
Views
1,694
First release
Last update
Rating
5.00 star(s) 1 ratings

More Excel articles from Worf

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top