Add New Variable to Shapes

Doflamingo · Sep 3, 2019

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 ?

Doflamingo · Sep 11, 2019

Another question ^^

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

Worf · Sep 12, 2019

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.

Worf · Sep 12, 2019

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

Doflamingo · Sep 14, 2019

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

Worf · Sep 14, 2019

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

Doflamingo · Sep 15, 2019

Hi @Worf

Many thanks again for having adapted the code to the variables, that works very well &#55357;&#56842;

Here find what I got after having run the macro

Doflamingo · Sep 15, 2019

https://imgur.com/xhQihVu

Doflamingo · Sep 15, 2019

Ok I find out how to use Imgur...

Doflamingo · Sep 15, 2019

Do you have any idea How to get rather this ?

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

Doflamingo · Sep 15, 2019

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

Add New Variable to Shapes

Doflamingo

Board Regular

Doflamingo

Board Regular

Excel Facts

Worf

Well-known Member

Worf

Well-known Member

Doflamingo

Board Regular

Worf

Well-known Member

Doflamingo

Board Regular

Doflamingo

Board Regular

Doflamingo

Board Regular

Doflamingo

Board Regular

Doflamingo

Board Regular

Similar threads

Forum statistics

Share this page

Add New Variable to Shapes

Board Regular

Board Regular

Excel Facts

Well-known Member

Well-known Member

Board Regular

Well-known Member

Board Regular

Board Regular

Board Regular

Board Regular

Board Regular

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock