Organization chart with VBA – Part 3

' sheet module

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Select Case MsgBox("Toggle pictures?", vbYesNo, "Images")
    Case vbYes
        Cancel = True
        Tog
    Case vbNo
        'MsgBox "no"
End Select
End Sub

Dim h%, w%, parr

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, dt As Worksheet, r As Range, tb As Shape
Set dt = Sheets("tdata")
Set ob = Sheets("fshap")
h = 1
w = 1
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
Phase3
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
RecPic
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, yf, x1, WorksheetFunction.Max([t:t])).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
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
        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 = 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(Cells(rn, col), 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
        ws.Shapes.AddShape(62, 10, 10, ws.Shapes(crar(i)).Width / 2.5, ws.Shapes(crar(i)).Height / 3).Name = _
        ws.Shapes(crar(i)).Name & "aux"
        With ws.Shapes(ws.Shapes(crar(i)).Name & "aux")
            .Left = ws.Shapes(crar(i)).Left
            .Top = ws.Shapes(crar(i)).Top + ws.Shapes(crar(i)).Height
            .Line.ForeColor.SchemeColor = 1
            .Line.Transparency = 1
            .Fill.Visible = msoFalse
            .TextFrame.Characters.Text = FormatPercent(Val(ad), 0, vbTrue, vbFalse, -2)
            .TextFrame.Characters(1, Len(ad)).Font.Size = 9
            .TextFrame.Characters(1, Len(ad)).Font.ColorIndex = 0
            .TextFrame.Characters(1, Len(ad)).Font.Bold = 1
            If ad = 0 Then .TextFrame.Characters.Text = "0%"
        End With
    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
'******************