Organization chart with VBA – Part 2

Worf · Jun 21, 2020

Worf submitted a new Excel article:

Organization chart with VBA – Part 2 - This version offers the option of starting at top or bottom.

VBA Code:
This is a continuation of the article mentioned below; instead of updating, I decided to create another one.

Now there is an option to make a top to bottom chart.

As before, the source table goes on a sheet named “fshap”.

You need to insert two sheets named “tdata” and “secdata”.

Part 1

View attachment 16719

VBA Code:

Dim h%, w% Sub main()...

Read more about this Excel article...

mj4345 · Jun 15, 2021

Hi - Nice code - do you have a copy of simpler version that doe not include descriptions or percentages? Thanks in advance!

Worf · Jun 18, 2021

Hi

I will prepare a simpler version...

Worf · Jun 20, 2021

Try this version, leaving the columns for description and percentages blank at the source range.

VBA Code:

Dim h%, w%

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
    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
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, xlPart)
    [q1] = [d74]
    [q2] = "*" & [m2] & "*"
    nr = Range("n" & Rows.Count).End(xlUp).Row
    For i = 2 To nr
        Cells(i + 1, "q") = "*" & Cells(i, "n") & "*"
    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, xlPart)
    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, xlPart)
        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.4
[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) = ws.Shapes(i).TextFrame2.TextRange.Text
        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(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

OllieHosking · Oct 1, 2021

Hi, this is a brilliant post, but when I copy the VBA and use it in my own excel workbook I get an run-time error code 91 on the r.offset lines of code. I have all three tabs set up with the data set also set up correctly.

Please could you advise on how to fix this error? (Also I'm a noob when it comes to VBA so any help will be wonderful!)

Kind regards,
Ollie

RichWilko · Oct 7, 2021

@Ollie

OllieHosking said:
Hi, this is a brilliant post, but when I copy the VBA and use it in my own excel workbook I get an run-time error code 91 on the r.offset lines of code. I have all three tabs set up with the data set also set up correctly.

Please could you advise on how to fix this error? (Also I'm a noob when it comes to VBA so any help will be wonderful!)

Kind regards,
Ollie

Hi Ollie, or Worf.

I am getting the same error on the same line, please can someone offer support or a suggestion of how to fix this?

This is awesome and would love to get it to work!

Thanks,
Rich

RichWilko · Oct 7, 2021

@Worf Any ideas on how to fix the above?

OllieHosking · Oct 8, 2021

Hi @Worf

I have been able to get this to work, but would you be able to change the code so both descriptions go into the boxes and that both descriptions are based off text?

Thank you,
Ollie

Rajat2285 · Jun 2, 2022

RichWilko said:
@Ollie

Hi Ollie, or Worf.

I am getting the same error on the same line, please can someone offer support or a suggestion of how to fix this?

This is awesome and would love to get it to work!

Thanks,
Rich

Hi Can someone share how to get the code working at r.offset line of code I am getting a error that line

Rajat2285 · Jun 2, 2022

Hi Worf

Can you please share the excel file with me

It would be of great help

Thanks in advance

Organization chart with VBA – Part 2

Worf

Well-known Member

Excel Facts

mj4345

New Member

Worf

Well-known Member

Worf

Well-known Member

OllieHosking

New Member

RichWilko

New Member

RichWilko

New Member

OllieHosking

New Member

Rajat2285

New Member

Rajat2285

New Member

Forum statistics

Share this page

Organization chart with VBA – Part 2

Well-known Member

Excel Facts

New Member

Well-known Member

Well-known Member

New Member

New Member

New Member

New Member

New Member

New Member

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock