Add New Variable to Shapes

[Doflamingo]

Hi all,

Here is the code to create a structure chart from range A to range C of the sheet ‘’BD’’

Here is a screenshot of the sheet ‘’BD’’
https://www.dropbox.com/s/vyik32v24dp2ysm/sheet BD.png?dl=0

There is the ‘’Big father‘’ in A2 which is the ‘’Boss’’

The column B states all the ‘’sub father’’ with their ‘’children’’ that are in the column A except for the value ‘’Boss’’

For example the ‘’Boss’’ in cell A2 is the father of ‘’Vice President’’ in cell A3 that is the father of ‘’Employee13’’ in cell A11

The column C of the sheet ‘’BD’’ is the description of what you see inside the shapes in the sheet ‘’Shapes’’ where the structure chart is displayed once the macro is activated

Here is a screenshot of the sheet ‘’Shapes’’ of what I have currently with the data of the sheet ''BD''

https://www.dropbox.com/s/9p4pm5ukdmyly8h/Sheet Shapes.png?dl=0

Here is the code I have to display the structure chart in the sheet ''Shapes''

Sub créeShape(parent, niv, Attribut, coul) ' procédure récursive
  hauteurshape = 48
  largeurshape = 85
  colonne = colonne + 1
  forga.Shapes.AddShape(msoShapeFlowchartAlternateProcess, 10, 10, largeurshape, hauteurshape).Name = parent
  forga.Shapes(parent).Line.ForeColor.SchemeColor = 1
  txt = parent & vbLf & Attribut
  With forga.Shapes(parent)
    .TextFrame.Characters.Text = txt
    .TextFrame.Characters(Start:=1, Length:=1000).Font.Size = 8
    .TextFrame.Characters(Start:=1, Length:=1000).Font.ColorIndex = 0
    .TextFrame.Characters(Start:=1, Length:=Len(parent)).Font.Bold = True
    .TextFrame.Characters(Start:=1, Length:=Len(parent)).Font.ColorIndex = 3
    .Fill.ForeColor.RGB = coul
  End With
  forga.Shapes(parent).Left = débutOrg.Left + inth * colonne
  forga.Shapes(parent).Top = débutOrg.Top + intv * (niv - 1)
  For i = 1 To n
    If Tbl(i, 1) = parent And niv > 1 Then
      shapePère = Tbl(i, 2)
      
      forga.Shapes.AddConnector(msoConnectorElbow, 100, 100, 100, 100).Name = parent & "c"
      
      forga.Shapes(parent & "c").Line.ForeColor.SchemeColor = 22
      forga.Shapes(parent & "c").ConnectorFormat.BeginConnect forga.Shapes(shapePère), 3
      forga.Shapes(parent & "c").ConnectorFormat.EndConnect forga.Shapes(parent), 1
      
   End If
   
   If Tbl(i, 2) = parent Then créeShape Tbl(i, 1), niv + 1, Tbl(i, 3), f.Cells(i + 1, 1).Interior.Color
  Next i
  
End Sub

My problem is that I would like to expand my variables, I add a new range of variable in the column D of the sheet ‘’BD’’ and I would like that the specific variable be not included in the shapes like the variable of the column C are, but rather be below and at the left of the shapes they are related to.

Here a screenshot of what I would like to obtain
https://www.dropbox.com/s/emm9bkqm9eanmfm/goal.png?dl=0

I have changes the code above with the red lines that represent the values of the column D but that does not work

Sub créeShape(parent, niv, Attribut, coul) ' procédure récursive
  hauteurshape = 48
  largeurshape = 85
  colonne = colonne + 1
  forga.Shapes.AddShape(msoShapeFlowchartAlternateProcess, 10, 10, largeurshape, hauteurshape).Name = parent
  forga.Shapes(parent).Line.ForeColor.SchemeColor = 1
  txt = parent & vbLf & Attribut
  With forga.Shapes(parent)
    .TextFrame.Characters.Text = txt
    .TextFrame.Characters(Start:=1, Length:=1000).Font.Size = 8
    .TextFrame.Characters(Start:=1, Length:=1000).Font.ColorIndex = 0
    .TextFrame.Characters(Start:=1, Length:=Len(parent)).Font.Bold = True
    .TextFrame.Characters(Start:=1, Length:=Len(parent)).Font.ColorIndex = 3
    .Fill.ForeColor.RGB = coul
  End With
  forga.Shapes(parent).Left = débutOrg.Left + inth * colonne
  forga.Shapes(parent).Top = débutOrg.Top + intv * (niv - 1)
  For i = 1 To n
    If Tbl(i, 1) = parent And niv > 1 Then
      shapePère = Tbl(i, 2)
      
      forga.Shapes.AddConnector(msoConnectorElbow, 100, 100, 100, 100).Name = parent & "c"
      
      forga.Shapes(parent & "c").Line.ForeColor.SchemeColor = 22
      forga.Shapes(parent & "c").ConnectorFormat.BeginConnect forga.Shapes(shapePère), 3
      forga.Shapes(parent & "c").ConnectorFormat.EndConnect forga.Shapes(parent), 1
      
   End If
   
   If Tbl(i, 2) = parent Then créeShape Tbl(i, 1), niv + 1, Tbl(i, 3), f.Cells(i + 1, 1).Interior.Color
  Next i
  
[COLOR=#ff0000]  For u = 1 To n[/COLOR]
[COLOR=#ff0000]    If Tbl(u, 1) = parent And niv > 1 Then[/COLOR]
[COLOR=#ff0000]      shapePère = Tbl(u, 2)[/COLOR]
[COLOR=#ff0000]      [/COLOR]
[COLOR=#ff0000]      forga.Shapes.AddConnector(msoConnectorElbow, 100, 100, 100, 100).Name = parent & "d"[/COLOR]
[COLOR=#ff0000]      [/COLOR]
[COLOR=#ff0000]      forga.Shapes(parent & "d").Line.ForeColor.SchemeColor = 22[/COLOR]
[COLOR=#ff0000]      forga.Shapes(parent & "d").ConnectorFormat.BeginConnect forga.Shapes(shapePère), 3[/COLOR]
[COLOR=#ff0000]      forga.Shapes(parent & "d").ConnectorFormat.EndConnect forga.Shapes(parent), 1[/COLOR]
[COLOR=#ff0000]      [/COLOR]
[COLOR=#ff0000]   End If[/COLOR]
[COLOR=#ff0000]   [/COLOR]
[COLOR=#ff0000]   If Tbl(u, 2) = parent Then créeShape Tbl(u, 1), niv + 1, Tbl(u, 3), f.Cells(u + 1, 1).Interior.Color[/COLOR]
[COLOR=#ff0000]  Next u[/COLOR]
  
  
End Sub

Any idea ?

 

[Worf]

Here is my idea to increase the connector length:

• Start with the current chart, which has the shapes correctly positioned on the horizontal axis.
• Delete all connectors.
• Increase the vertical shape spacing.
• Draw all connectors again.

I will write code that performs these actions.

 

[Worf]

This code modifies the chart shown at post 57, increasing the vertical spacing. Next step will be adding the connectors.

Sub Phase2()
Dim ws As Worksheet, i%, s As Shape, r As Range, lr%, delta, v%, sn As Shape
Set ws = ActiveSheet
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"
[g74] = "top"
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)
        Set r = r.Offset(1)
    End If
Next
lr = Range("b" & Rows.Count).End(xlUp).Row
Range("B74:B" & lr).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=[G74:G75], _
CopyToRange:=[h74], Unique:=True
lr = Range("h" & Rows.Count).End(xlUp).Row
ws.Sort.SortFields.Clear
ws.Sort.SortFields.Add Key:=[h75], SortOn:=xlSortOnValues, Order:=2, DataOption:=0
With ws.Sort
    .SetRange Range("H75:H" & lr)
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
Range("i75:i" & lr).Formula = "=row()-74"
lr = Range("b" & Rows.Count).End(xlUp).Row
Range("f75:f" & lr).Formula = "=match(b75,$h$75:$h$" & lr & ",0)"
delta = WorksheetFunction.Max([e:e])
For i = 75 To lr
    Set sn = ws.Shapes(Range("a" & i))
    sn.Top = 2000 - delta * Range("f" & i) * 2              ' new vertical position
    ws.Shapes(Range("a" & i) & "aux").Top = sn.Top + sn.Height
Next
End Sub

 

[Worf]

• The version below shows how to add the connectors; it currently works only at the first group. It is not finished but I wanted to post for backup reasons… the code will appear on the next post.
• Our shapes do not appear to have connection points on the middle, so elbow connectors are not an option. I am using simple lines instead.
• I went back to the dual sheet method because the shapes were moving around with all the range manipulation. When the chart is ready, we can go back to the single sheet setup if you want to. The solution may be to change the shapes’ placement property.
• This week I am on a twelve-hour shift at work so I will probably not return here until Saturday…

 

[Worf]

Sub Phase2()    ' increases vertical spacing
Dim ws As Worksheet, i%, s As Shape, r As Range, lr%, delta, v%, sn As Shape, dt As Worksheet
Set dt = Sheets("data3"): Set ws = Sheets("object")
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
lr = Range("i" & Rows.Count).End(xlUp).Row
dt.Sort.SortFields.Clear
dt.Sort.SortFields.Add Key:=[i75], SortOn:=xlSortOnValues, Order:=2, DataOption:=0
With dt.Sort
    .SetRange Range("i75:i" & lr)
    .Header = xlNo:    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin:    .Apply
End With
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
delta = WorksheetFunction.Max([e:e])
For i = 75 To lr
    Set sn = ws.Shapes(Range("a" & i))
    sn.Top = 2000 - delta * Range("f" & i) * 2              ' new vertical position
    ws.Shapes(Range("a" & i) & "aux").Top = sn.Top + sn.Height
Next
End Sub


Sub Phase3()    ' draws connectors
Dim v, r As Range, lasto%, i%, y1, y2, yf, x1, x2, ws As Worksheet, dt As Worksheet
Set ws = Sheets("object"): Set dt = Sheets("data3")
ws.[a1].CurrentRegion.Copy dt.[a1]
dt.Activate
[g1:z70].ClearContents:    [g1] = [b1]
v = Split([a1].CurrentRegion.Address, "$")(4)
Range("b1:b" & v).AdvancedFilter xlFilterCopy, [g1:g2], [k1], True
[m1] = [g1]: [m2] = [k2]
Range("a1:b" & v).AdvancedFilter xlFilterCopy, [m1:m2], [n1], False
Set r = [d:d].Find([m2], [d1], xlValues, xlPart)
[q1] = [d74]
[q2] = "*" & [m2] & "*"
For i = 2 To Range("n" & Rows.Count).End(xlUp).Row
    Cells(i + 1, "q") = "*" & Cells(i, "n") & "*"
Next
lasto = Range("q" & Rows.Count).End(xlUp).Row
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
    .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
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
End Sub

 

[Doflamingo]

Hi @Worf, I hoe you are well

I understand your point

I went back to the dual sheet method because the shapes were moving around with all the range manipulation. When the chart is ready, we can go back to the single sheet setup if you want to. The solution may be to change the shapes’ placement property.

Indeed I have created 2 different sheets ''data3'' and ''object''

I have put the values in the sheet ''data3'' from column A to column E, like I used to do previously. But I don't know why, I used the code you posted at post 64, I have this error message

See Screenshot

https://www.dropbox.com/s/1coghq8mdwh365t/error.png?dl=0

For the lines

[/COLOR]Range("B74:B" & lr).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=[G74:G75], _[COLOR=#333333]
[/COLOR]
CopyToRange:=[h74], Unique:=True[COLOR=#333333]

When the chart is ready, I would prefer to go back to the single sheet setup like you suggested it

But I understand your logic, I think you're right. Better use lines connectors than elbow connectors

Many thanks for what you have done so far

Kind regards

D.

 

[Worf]

Hi


It is already drawing all connectors, but some tweaks are in order. The code has issues with names like B2 and B2-1 because it currently does a partial match, I will change that.
Next step is to produce a one-click routine that performs all steps at once.

 

[Worf]

Sub Phase3()    ' draws connectors
Dim v, r As Range, lasto%, i%, y1, y2, yf, x1, x2, ws As Worksheet, dt As Worksheet, j%
Set ws = Sheets("object"): Set dt = Sheets("data3")
ws.[a1].CurrentRegion.Copy dt.[a1]
dt.Activate
[g1:z70].ClearContents:    [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] & "*"
    For i = 2 To Range("n" & Rows.Count).End(xlUp).Row
        Cells(i + 1, "q") = "*" & Cells(i, "n") & "*"
    Next
    lasto = Range("q" & Rows.Count).End(xlUp).Row
    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
    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
End Sub

 

[Doflamingo]

Hello @Worf

Many thanks for your explanation about names like B2 and B2-1

So I changed the values from column A to column E in the sheet ''data3'', and I put the same values than the ones from your chart in the post#66

[TABLE="width: 550"]
<colgroup><col span="5"></colgroup><tbody>[TR]
[TD]Son[/TD]
[TD]Father[/TD]
[TD]Description[/TD]
[TD]description 1[/TD]
[TD]PEP[/TD]
[/TR]
[TR]
[TD]Fonction A1[/TD]
[TD]Fonction C0[/TD]
[TD]desc1[/TD]
[TD]0.3[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Fonction D1[/TD]
[TD]Fonction C0[/TD]
[TD]desc2[/TD]
[TD]0.2[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Fonction C1[/TD]
[TD]Fonction C0[/TD]
[TD]desc3[/TD]
[TD]0.1[/TD]
[TD]O[/TD]
[/TR]
[TR]
[TD]Fonction E1[/TD]
[TD]Fonction D1[/TD]
[TD]desc4[/TD]
[TD]0.6[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Fonction H1[/TD]
[TD]Fonction D1[/TD]
[TD]desc5[/TD]
[TD]0.8[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Fonction A2[/TD]
[TD]Fonction C1[/TD]
[TD]desc6[/TD]
[TD]0.5[/TD]
[TD]O[/TD]
[/TR]
[TR]
[TD]Fonction J3[/TD]
[TD]Fonction C1[/TD]
[TD]desc7[/TD]
[TD]0.2[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Fonction D2[/TD]
[TD]Fonction A1[/TD]
[TD]desc8[/TD]
[TD]0.9[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Fonction B2[/TD]
[TD]Fonction A1[/TD]
[TD]desc9[/TD]
[TD]0.1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Fonction C2[/TD]
[TD]Fonction A1[/TD]
[TD]desc10[/TD]
[TD]0[/TD]
[TD]O[/TD]
[/TR]
[TR]
[TD]Fonction G1[/TD]
[TD]Fonction E1[/TD]
[TD]desc11[/TD]
[TD]0.3[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Fonction F1[/TD]
[TD]Fonction E1[/TD]
[TD]desc12[/TD]
[TD]0.3[/TD]
[TD]O
[/TD]
[/TR]
</tbody>[/TABLE]

And normally if I understand well, the chart is supposed to be displayed in the sheet ''object'' that is an empty sheet

But I still have the same error message than the one in the post #65

with the code below ... the error message appears when I try to launch the macro ''phase 2''

[/COLOR]Sub Phase2()    ' increases vertical spacingDim ws As Worksheet, i%, s As Shape, r As Range, lr%, delta, v%, sn As Shape, dt As Worksheet
Set dt = Sheets("data3"): Set ws = Sheets("object")
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
lr = Range("i" & Rows.Count).End(xlUp).Row
dt.Sort.SortFields.Clear
dt.Sort.SortFields.Add Key:=[i75], SortOn:=xlSortOnValues, Order:=2, DataOption:=0
With dt.Sort
    .SetRange Range("i75:i" & lr)
    .Header = xlNo:    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin:    .Apply
End With
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
delta = WorksheetFunction.Max([e:e])
For i = 75 To lr
    Set sn = ws.Shapes(Range("a" & i))
    sn.Top = 2000 - delta * Range("f" & i) * 2              ' new vertical position
    ws.Shapes(Range("a" & i) & "aux").Top = sn.Top + sn.Height
Next
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%
Set ws = Sheets("object"): Set dt = Sheets("data3")
ws.[a1].CurrentRegion.Copy dt.[a1]
dt.Activate
[g1:z70].ClearContents:    [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] & "*"
    For i = 2 To Range("n" & Rows.Count).End(xlUp).Row
        Cells(i + 1, "q") = "*" & Cells(i, "n") & "*"
    Next
    lasto = Range("q" & Rows.Count).End(xlUp).Row
    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
    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
End Sub


[COLOR=#333333]

Would you, please, give me access to the workbook directly, like you did before ? It would be easier for me to understand

Many thanks in advance

Kind regards

 

[Worf]

I was running the pieces manually, that is not user friendly. Currently we have three tasks: create the chart, increase spacing and redraw the connectors.
The code below performs the first two steps with one click. To avoid human intervention I am using three sheets: Data2 to store the table, Data3 for calculations and object for the diagram.
If you have any trouble with this, I will be happy to share my workbook. After your testing, I will implement the third phase, which is drawing the connectors.

Sub main()                                                  ' run me
Dim i%, ob As Worksheet
Application.CutCopyMode = 0
Set ob = Sheets("object")
Sheets("data3").Cells.ClearContents
Sheets("data2").[L37].CurrentRegion.Copy                    ' original table
ob.[a1].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
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
[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()    ' increases vertical spacing
Dim ws As Worksheet, i%, s As Shape, r As Range, lr%, delta, v%, sn As Shape, dt As Worksheet
Set dt = Sheets("data3"): Set ws = Sheets("object")
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
lr = Range("i" & Rows.Count).End(xlUp).Row
dt.Sort.SortFields.Clear
dt.Sort.SortFields.Add Key:=[i75], SortOn:=xlSortOnValues, Order:=2, DataOption:=0
With dt.Sort
    .SetRange Range("i75:i" & lr)
    .Header = xlNo:    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin:    .Apply
End With
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
delta = WorksheetFunction.Max([e:e])
For i = 75 To lr
    Set sn = ws.Shapes(Range("a" & i))
    sn.Top = 2000 - delta * Range("f" & i) * 2              ' new vertical position
    ws.Shapes(Range("a" & i) & "aux").Top = sn.Top + sn.Height
Next
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
Range("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(Source As Worksheet)
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
Set sal = Application.SmartArtLayouts(89)
Set oshp = ws.Shapes.AddSmartArt(sal)
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 Source.Cells(L, 1) <> ""
    If Source.Cells(L, 2) = Source.Cells(L, 3) Then
        Set QNode = oshp.SmartArt.AllNodes.Add
        QNode.TextFrame2.TextRange.Text = Source.Cells(L, 2)
        PID = Source.Cells(L, 2)         ' parent node
        Source.Rows(L).Delete
        AddChildNodes QNode, Source, 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")
Selection.ShapeRange.IncrementRotation 180
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 = 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

 

[Doflamingo]

Hello @Worf

Many thanks for the explanations

Like you wrote it, I created 3 differents sheets ''Data2'', ''Data3'' and ''object''. The only sheet not empty is ''Data2'' that contains the values

[TABLE="class: cms_table, width: 550"]
<tbody>[TR]
[TD]Son[/TD]
[TD]Father[/TD]
[TD]Description[/TD]
[TD]description 1[/TD]
[TD]PEP[/TD]
[/TR]
[TR]
[TD]Fonction A1[/TD]
[TD]Fonction C0[/TD]
[TD]desc1[/TD]
[TD]0.3[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Fonction D1[/TD]
[TD]Fonction C0[/TD]
[TD]desc2[/TD]
[TD]0.2[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Fonction C1[/TD]
[TD]Fonction C0[/TD]
[TD]desc3[/TD]
[TD]0.1[/TD]
[TD]O[/TD]
[/TR]
[TR]
[TD]Fonction E1[/TD]
[TD]Fonction D1[/TD]
[TD]desc4[/TD]
[TD]0.6[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Fonction H1[/TD]
[TD]Fonction D1[/TD]
[TD]desc5[/TD]
[TD]0.8[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Fonction A2[/TD]
[TD]Fonction C1[/TD]
[TD]desc6[/TD]
[TD]0.5[/TD]
[TD]O[/TD]
[/TR]
[TR]
[TD]Fonction J3[/TD]
[TD]Fonction C1[/TD]
[TD]desc7[/TD]
[TD]0.2[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Fonction D2[/TD]
[TD]Fonction A1[/TD]
[TD]desc8[/TD]
[TD]0.9[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Fonction B2[/TD]
[TD]Fonction A1[/TD]
[TD]desc9[/TD]
[TD]0.1[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Fonction C2[/TD]
[TD]Fonction A1[/TD]
[TD]desc10[/TD]
[TD]0[/TD]
[TD]O[/TD]
[/TR]
[TR]
[TD]Fonction G1[/TD]
[TD]Fonction E1[/TD]
[TD]desc11[/TD]
[TD]0.3[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Fonction F1[/TD]
[TD]Fonction E1[/TD]
[TD]desc12[/TD]
[TD]0.3[/TD]
[TD]O









[/TD]
[/TR]
</tbody>[/TABLE]