Worf

Organization chart with VBA – Part 2

Overview Discussion
Worf

Worf

Well-known Member
Joined
Oct 30, 2011
Messages
4,252
Worf submitted a new Excel article:

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

  • 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()...
Click to expand...

Read more about this Excel article...
 

Excel Facts

What do {} around a formula in the formula bar mean?
{Formula} means the formula was entered using Ctrl+Shift+Enter signifying an old-style array formula.
Hi - Nice code - do you have a copy of simpler version that doe not include descriptions or percentages? Thanks in advance!
 
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
 
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
 
@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
Click to expand...
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 @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
 
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
Click to expand...
Hi Can someone share how to get the code working at r.offset line of code I am getting a error that line
 
Hi Worf

Can you please share the excel file with me

It would be of great help

Thanks in advance
 
You must log in or register to reply here.

Forum statistics

Threads
1,214,515
Messages
6,119,972
Members
448,933
Latest member
Bluedbw

Share this page

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