Add New Variable to Shapes

D

Doflamingo

Board Regular
Joined
Apr 16, 2019
Messages
238
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''

Code: 
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

Code: 
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 ?
 
Sort by date Sort by votes
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.
 
Upvote 0

Excel Facts

Select a hidden cell
Somehide hide payroll data in column G? Press F5. Type G1. Enter. Look in formula bar while you arrow down through G.
This code modifies the chart shown at post 57, increasing the vertical spacing. Next step will be adding the connectors.

Code: 
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
 
Upvote 0
  • 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…

u7ks0X0.jpg
 
Upvote 0
Code: 
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
 
Upvote 0
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

Code: 
[/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.



 
Upvote 0
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.

TcMfpw7.png
 
Upvote 0
Code: 
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
 
Upvote 0
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

SonFatherDescriptiondescription 1PEP
Fonction A1Fonction C0desc10.3
Fonction D1Fonction C0desc20.2
Fonction C1Fonction C0desc30.1O
Fonction E1Fonction D1desc40.6
Fonction H1Fonction D1desc50.8
Fonction A2Fonction C1desc60.5O
Fonction J3Fonction C1desc70.2
Fonction D2Fonction A1desc80.9
Fonction B2Fonction A1desc90.1
Fonction C2Fonction A1desc100O
Fonction G1Fonction E1desc110.3
Fonction F1Fonction E1desc120.3O

<colgroup><col span="5"></colgroup><tbody>
</tbody>

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''

Code: 
[/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
 
Upvote 0
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.

Code: 
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
 
Upvote 0
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

SonFatherDescriptiondescription 1PEP
Fonction A1Fonction C0desc10.3
Fonction D1Fonction C0desc20.2
Fonction C1Fonction C0desc30.1O
Fonction E1Fonction D1desc40.6
Fonction H1Fonction D1desc50.8
Fonction A2Fonction C1desc60.5O
Fonction J3Fonction C1desc70.2
Fonction D2Fonction A1desc80.9
Fonction B2Fonction A1desc90.1
Fonction C2Fonction A1desc100O
Fonction G1Fonction E1desc110.3
Fonction F1Fonction E1desc120.3O










<tbody>
</tbody>
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Question
VBA add textbox to shapes
Replies
1
Views
2K
DanteAmor
DanteAmor
D
  • Question
Rearange structure chart for better display
Replies
0
Views
584
Doflamingo
D
D
  • Question
ConnectorElbow or arrow completely vertical or horizontal between 2 shapes
Replies
0
Views
976
Doflamingo
D

Forum statistics

Threads
1,214,887
Messages
6,122,095
Members
449,064
Latest member
Danger_SF

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