VBA to create organisation chart

[jbesclapez]

Hi there,

I found a great macro on the web that nearly does my job. But only nearly. Unfortunately this code is really high level, and I have no idea how to solve it. Super challenging!
You can download the file here:
orgaproblem
And what I would like to achieve is below: (see picture)

Note that there is a limitation.
The children of G in the second table should only show once in the hierarchy otherwise it will be to messy.

Thanks for your help

 

[jbesclapez]

Do you have any idea of this error?

Yes. I need to know your Excel version.

I am using Excel 365 v1908 Semi Annual

I was also thinking if you send me the file directly, i should fine my way around VBA.

Thanks for sharing your work, it looks really great!

 

[Worf]

• You can easily re-create my workbook; just paste the code, the source table, rename the worksheets and that is it.
• As I think I know what the problem is, I will point you into the right direction.
• Please turn the macro recorder on, insert the shape below at smart art> hierarchy and paste the resulting code here. I am showing what I got, I do not have Office 365 to test with.
• Which one of my codes are you using? Note that the original thread has top to bottom and bottom to top charts, but the article only one option so far.

' Excel 2016

Sub Macro1()
''
Call ActiveSheet.Shapes.AddSmartArt(Application.SmartArtLayouts( _
"urn:microsoft.com/office/officeart/2008/layout/NameandTitleOrganizationalChart")).Select
End Sub

 

[jbesclapez]

And here is mine :

Sub Macro2()
    Call ActiveSheet.Shapes.AddSmartArt(Application.SmartArtLayouts( _
        "urn:microsoft.com/office/officeart/2008/layout/NameandTitleOrganizationalChart" _
        )).Select

End Sub

I am trying to use your original code i found. That is the one not working on my office 365

 

[jbesclapez]

So our codes are the same...

But just to be sure, the error i am having is on

Sub Phase1()                                            ' draw original chart
Dim arr(), i%, t
[B]arr = Range([a1].CurrentRegion.Address) [/B]                ' ERROR save original table

I copied your example data in a sheet called tdata, copy the VBA and created 2 other sheets secdata and fshap...

Could you send me a full working sheet? I have no idea what I am doing wrong !

 

[Worf]

• First of all, the source table goes on “fshap”, my post is not that clear on this aspect… this alone can solve the issue. The sheet names are not helping.
• I can send you a test workbook, but before let´s check the version thing.
• That recorded part is the same for 2016 and 365, this is important information.
• Note that the original thread was written for Excel 2013, while the article supports 2013 and 2016. I am assuming you are using the article version.
• What is the error message you get? The range is probably empty.
• What do you get when running the code below? I would expect 16.

Sub MyVer()

MsgBox Val(Application.Version)

End Sub

 

[jbesclapez]

Hi Worf,

It is version 16.

The macro is now working!
It took me a while to realize that i wrote "secdata " and not ''secdata" (note the space -and it drove me crazy!!!)

Now I need to find the macro for Top to bottom

Please could you update your post for everybody! That would be really nice!

Have a good week end

 

[jbesclapez]

I can send you a test workbook, but before let´s check the version thing.
End Sub[/CODE]

Worf, could you still please send me the worksheet from TOP to BOTTOM. Thanks.
Also, i realized that you are probably better in Microsoft Excef than Microsoft Worf. - Sorry for the bad joke.

 

[Worf]

Since we are at the bad jokes department, which rock star is great at spreadsheets?

Spoiler: answer

Excel Rose.

Listen to me...


The code below is based on the original thread and creates a top to bottom chart with Excel 2016; I am planning to update the article tomorrow.

Note that for this example you need two sheets, named object and data2.

OrgaProblem.xlsm
	A	B	C	D
1	Son	Father	Description	description 1
2	Fonction A1	Fonction C0	desc1	30%
3	Fonction B2	Fonction A1	desc2	20%
4	Fonction C2	Fonction A1	desc3	10%
5	Fonction D2	Fonction A1	desc4	60%
6	Fonction C1	Fonction C0	desc5	80%
7	Fonction J1	Fonction C1	desc6	50%
8	Fonction A2	Fonction C1	desc7	20%
9	Fonction D1	Fonction C0	desc8	90%
10	Fonction B2-2	Fonction D1	desc9	10%
11	Fonction E1	Fonction D1	desc10	0%
12	Fonction F1	Fonction E1	desc11	30%
13	Fonction G1	Fonction E1	desc12	30%
data2

Sub main()  ' run me
Adjust
CreateDiagram Sheets("object")
End Sub

Sub Adjust()
Dim lr%
Sheets("data2").Activate
[k:o].ClearContents
lr = Range("a" & Rows.Count).End(xlUp).Row
[k1] = "Seq": [L1] = "code1": [m1] = "code2"
[L2] = [b2]: [n1] = "info": [o1] = "info2"
[L2].Interior.Color = RGB(200, 50, 10)
[m2] = [b2]: [k2] = 2: [n2] = 0.01
[o2] = "desc0"
Range("a2:a" & lr).Copy [L3]
Range("b2:b" & lr).Copy [m3]
Range("c2:c" & lr).Copy [o3]
Range("d2:d" & lr).Copy [n3]
Range("k3:k" & lr + 1).Formula = "=row()"
End Sub

Sub CreateDiagram(Source As Worksheet)
Dim sal As SmartArtLayout, QNode As SmartArtNode, QNodes As SmartArtNodes, oshp As Shape, Line%, _
i%, r As Range, PID$, mn, mx, ws As Worksheet, dt As Worksheet, crar(), c%, ad, v, t, s As ShapeRange
c = 1
ReDim crar(1 To c)
Set ws = Sheets("object"): Set dt = Sheets("data2")
ws.Activate
ws.[a:f].ClearContents
dt.[k1].CurrentRegion.Copy ws.[a1]
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
Line = 2                                     ' look for roots
Do While Source.Cells(Line, 1) <> ""
    If Source.Cells(Line, 2) = Source.Cells(Line, 3) Then
        Set QNode = oshp.SmartArt.AllNodes.Add
        QNode.TextFrame2.TextRange.Text = Source.Cells(Line, 2)
        PID = Source.Cells(Line, 2)         ' parent node
        Source.Rows(Line).Delete
        AddChildNodes QNode, Source, PID
    Else
        Line = Line + 1
    End If
Loop
oshp.SmartArt.AllNodes(1).TextFrame2.TextRange.Text = dt.[L2]
oshp.Width = 1000
oshp.Height = 700
oshp.Select
CommandBars.ExecuteMso ("SmartArtConvertToShapes")
Selection.Ungroup
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 = dt.Range("L:L").Find(v, dt.[L1], 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"
        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 + 2
            .Line.ForeColor.SchemeColor = 1
            .Fill.Visible = msoFalse
            .TextFrame.Characters.Text = FormatPercent(ad, 0, vbTrue, vbFalse, vbUseDefault)
            .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
'****************

 

[Worf]

The workbook:

OrgaProblem.xlsm

 

[jbesclapez]

The workbook:

OrgaProblem.xlsm

Excel Rose .... I should have guessed that one. Well played! LOL

I used the workbook you sent me.
The macro has a major limitation that makes it nearly unsuable. The weird thing, is that I do not think you had this limitation in the past. Let me explain :
The more members you add to the data2, the smaller the chart gets. And at the end it is so small that it makes it unreadable...