Add New Variable to Shapes

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 ?
 
Another question ^^

How have you succeeded to post a screenshot directly ? I have to use dropbox... maybe not the best alternative
 
Upvote 0

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes
I am using Imgur to upload pictures, when you choose direct link there it will display itself here.

I will be back later with code updates.
 
Upvote 0
New version:

Code:
Dim colonne%, débutOrg As Range, f As Worksheet, forga As Worksheet, inth%, intv%, Tbl()
Sub orga()
Dim s As Shape
'-------------------------------------niveau 0
Set f = Sheets("data1")
Set forga = Sheets("test1")
forga.Activate
Tbl = f.Range("a2:d" & f.[A65000].End(xlUp).Row).Value
For Each s In forga.Shapes
    If s.Type = 17 Or s.Type = 1 Then s.Delete
Next
MsgBox "Ready?"
inth = 70:   intv = 100:   colonne = 0
Set débutOrg = forga.[e20]
créeShape f.[p2], 1, f.[p3], f.[c2].Interior.Color, f.[d2]
End Sub


Sub créeShape(parent, niv, Attribut, coul, ad) ' procédure récursive
Dim hshape%, lshape%, i%, spere$
hshape = 48:  lshape = 85
colonne = colonne + 1
forga.Shapes.AddShape(62, 10, 10, lshape, hshape).Name = parent
forga.Shapes.AddShape(62, 10, 10, lshape / 2.5, hshape / 3).Name = parent & "aux"
With forga.Shapes(parent & "aux")
    .Line.ForeColor.SchemeColor = 1
    .Left = débutOrg.Left + inth * colonne
    .Fill.Visible = msoFalse
    .Top = débutOrg.Top - intv * (niv - 1) + forga.Shapes(parent).Height + 5
    .TextFrame.Characters.Text = FormatPercent(ad, 0, vbTrue, vbFalse, vbUseDefault)
    .TextFrame.Characters(1, Len(ad)).Font.Size = 8
    .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
With forga.Shapes(parent)
    .Line.ForeColor.SchemeColor = 1
    .TextFrame.Characters.Text = parent & vbLf & Attribut
    .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
    .Left = débutOrg.Left + inth * colonne
    .Top = débutOrg.Top - intv * (niv - 1)
End With
For i = 1 To UBound(Tbl)
    If Tbl(i, 1) = parent And niv > 1 Then
        spere = Tbl(i, 2)
        forga.Shapes.AddConnector(2, 100, 100, 100, 100).Name = parent & "c"
        forga.Shapes(parent & "c").Line.ForeColor.SchemeColor = 22
        forga.Shapes(parent & "c").ConnectorFormat.BeginConnect forga.Shapes(spere), 1
        forga.Shapes(parent & "c").ConnectorFormat.EndConnect forga.Shapes(parent), 3
    End If
    If Tbl(i, 2) = parent Then créeShape Tbl(i, 1), niv + 1, Tbl(i, 3), coul, Tbl(i, 4)
Next
End Sub
 
Upvote 0
Hi @ Worf

Many thanks for your reply. It works perfectly :)

Here find the codes that allows to automatically autospace shapes horizontally.

Code:
Sub AutoSpace_Shapes_Horizontal()
'Automatically space and align shapes horizontally.


Dim shp As Shape
Dim lCnt As Long
Dim dTop As Double
Dim dLeft As Double
Dim dWidth As Double
Const dSPACE As Double = 8 'Set space between shapes in points


  'Check if shapes are selected
  If TypeName(Selection) = "Range" Then
    MsgBox "Please select shapes before running the macro."
    Exit Sub
  End If
  
  'Set variables
  lCnt = 1
  
  'Loop through selected shapes (charts, slicers, timelines, etc.)
  For Each shp In Selection.ShapeRange
    With shp
      'If not first shape then move to right of previous shape and align top.
      If lCnt > 1 Then
        .Top = dTop
        .Left = dLeft + dWidth + dSPACE
      End If
      
      'Store properties of shape for use in moving next shape in the collection.
      dTop = .Top
      dLeft = .Left
      dWidth = .Width
    End With
    
    'Add to shape counter
    lCnt = lCnt + 1
  Next shp


End Sub

So you just have to select the shapes and then run the macro.

I try to adapt it with the code you gave me because currently shapes are not well displayed as you have seen it.

but currently I select the shapes in order there are more space between them like the macro above allows it to do. But I realized at each time the little shapes representing the values of the column D where there are the % don't move so at each time i have to move them manually with the mouse of my laptop.

Many thanks for your help and your time. It really helped me :)

If you have any idea about how to adapt the code above with the big shapes ant the little shapes, please let me know

Kind regards
 
Upvote 0
Hi

Code:
Sub AutoSpace_Shapes_Horizontal()
'Automatically space and align shapes horizontally.
Dim shp As Shape, lCnt%, dTop#, dLeft As Double, dWidth#, ws As Worksheet
Const dSPACE As Double = 8 'Set space between shapes in points
Set ws = ActiveSheet
If TypeName(Selection) = "Range" Then
    MsgBox "Please select shapes before running the macro."
    Exit Sub
End If
lCnt = 1
'Loop through selected shapes (charts, slicers, timelines, etc.)
For Each shp In Selection.ShapeRange
    With shp
        'If not first shape then move to right of previous shape and align top.
        If lCnt > 1 Then
            .Top = dTop
            .Left = dLeft + dWidth + dSPACE
        End If
        'Store properties of shape for use in moving next shape in the collection.
        dTop = .Top
        dLeft = .Left
        dWidth = .Width
    End With
    ws.Shapes(shp.Name & "aux").Top = shp.Top + shp.Height + 5  ' position little shapes
    ws.Shapes(shp.Name & "aux").Left = shp.Left
    lCnt = lCnt + 1
Next
End Sub
 
Upvote 0
Hi @Worf

Many thanks again for having adapted the code to the variables, that works very well ��

Here find what I got after having run the macro
 
Upvote 0
xhQihVu.png


Ok I find out how to use Imgur...
 
Upvote 0
Do you have any idea How to get rather this ?

d1eccHB.png


Because when I have ran the macro you adapted then I move the selected shapes with my mouse, but currently looking for to automate this. I focus mainly on the idea of shapes number above the shape below ... if the figure is odd or even

Many thanks again for your time and your help on this subject
 
Upvote 0
I realize that all the shapes go to the right direction.

I try to find the balance between the left and the right in order that the chart be well displayed. It make me think to a regression tree in Python
 
Upvote 0

Forum statistics

Threads
1,213,515
Messages
6,114,080
Members
448,548
Latest member
harryls

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