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

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.
Many Thanks @Worf

I keep working on it. But I'm sure there is something to find the right balance between right and left in order to get a proper display.

Kind regards
 
Upvote 0
The get data procedure is a start, it collects necessary information:

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, -2)
    .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 & "conn"
        forga.Shapes(parent & "conn").Line.ForeColor.SchemeColor = 22
        forga.Shapes(parent & "conn").ConnectorFormat.BeginConnect forga.Shapes(spere), 1
        forga.Shapes(parent & "conn").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


Sub get_data()
Dim s As Shape, r As Range, i%, ws As Worksheet, m
Set ws = Sheets("test1")
Set r = [f2]
[g1] = "top": [j1] = "top": [n1] = [b1]
[f1] = "shape": [m1] = "# of shapes"
[h1] = "left": [s1] = "# of sons"
For i = 1 To ws.Shapes.Count
    If Not ws.Shapes(i).Name Like "*aux" And Not ws.Shapes(i).Name Like "*conn" Then
        r = ws.Shapes(i).Name
        r.Offset(, 1) = Round(ws.Shapes(i).Top, 0)
        r.Offset(, 2) = Round(ws.Shapes(i).Left, 0)
        Set r = r.Offset(1)
    End If
Next
[g:g].AdvancedFilter xlFilterCopy, [j1:j2], [L1], 1
Range("m2:m" & Range("L" & Rows.Count).End(xlUp).Row).Formula = "=countif(g:g,""=""&L2)"
m = WorksheetFunction.Max([h:h])
Set r = [h:h].Find(m, [h1], xlValues, xlWhole)
MsgBox "Chart width will be " & Round(ws.Shapes(r.Offset(, -2)).Width + m, 0) & " points."
[b:b].AdvancedFilter xlFilterCopy, [n1:n2], [r1], 1
Range("s2:s" & Range("r" & Rows.Count).End(xlUp).Row).Formula = "=countif(b:b,""=""&r2)"
End Sub
 
Upvote 0
Hello @ Worf

Many thanks for your answer

I tried the macro you developed but I don’t know why, it gives me the same result than before …

Here find what I get when I run the macro in the sheet ‘’test1’’ with the data of sheet ‘’data1’’

https://www.dropbox.com/s/s5f4to1ryrwmltc/Current.png?dl=0

And here what I’m looking for

https://www.dropbox.com/s/tjxsm3j6ozsyd6k/Goal.png?dl=0

Because currently I do it with the macro autospace horizontal that you kindly reviewed and also with ''Ctrl'' button of my keyboard + the use of my mouse but it takes a little bit of time and I think if there are more data added in the sheet ''data1'', it's going to be really hard to arrange at each time I run thee macro

Below, I've just changed the cell location where the chart begins, here in red

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
[COLOR=#FF0000]Set débutOrg = forga.[e50][/COLOR]
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, -2)
    .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 & "conn"
        forga.Shapes(parent & "conn").Line.ForeColor.SchemeColor = 22
        forga.Shapes(parent & "conn").ConnectorFormat.BeginConnect forga.Shapes(spere), 1
        forga.Shapes(parent & "conn").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




Sub get_data()
Dim s As Shape, r As Range, i%, ws As Worksheet, m
Set ws = Sheets("test1")
Set r = [f2]
[g1] = "top": [j1] = "top": [n1] = [b1]
[f1] = "shape": [m1] = "# of shapes"
[h1] = "left": [s1] = "# of sons"
For i = 1 To ws.Shapes.Count
    If Not ws.Shapes(i).Name Like "*aux" And Not ws.Shapes(i).Name Like "*conn" Then
        r = ws.Shapes(i).Name
        r.Offset(, 1) = Round(ws.Shapes(i).Top, 0)
        r.Offset(, 2) = Round(ws.Shapes(i).Left, 0)
        Set r = r.Offset(1)
    End If
Next
[g:g].AdvancedFilter xlFilterCopy, [j1:j2], [L1], 1
Range("m2:m" & Range("L" & Rows.Count).End(xlUp).Row).Formula = "=countif(g:g,""=""&L2)"
m = WorksheetFunction.Max([h:h])
Set r = [h:h].Find(m, [h1], xlValues, xlWhole)
MsgBox "Chart width will be " & Round(ws.Shapes(r.Offset(, -2)).Width + m, 0) & " points."
[b:b].AdvancedFilter xlFilterCopy, [n1:n2], [r1], 1
Range("s2:s" & Range("r" & Rows.Count).End(xlUp).Row).Formula = "=countif(b:b,""=""&r2)"
End Sub
 
Upvote 0
Because I try to understand the variable in red

Code: 
Sub get_data()
Dim s As Shape, r As Range, i%, ws As Worksheet, m
Set ws = Sheets("test1")
[COLOR=#ff0000]Set r = [f2][/COLOR]
[COLOR=#ff0000][g1] = "top": [j1] = "top": [n1] = [b1][/COLOR]
[COLOR=#ff0000][f1] = "shape": [m1] = "# of shapes"[/COLOR]
[COLOR=#ff0000][h1] = "left": [s1] = "# of sons"[/COLOR]
For i = 1 To ws.Shapes.Count
    If Not ws.Shapes(i).Name Like "*aux" And Not ws.Shapes(i).Name Like "*conn" Then
        r = ws.Shapes(i).Name
        r.Offset(, 1) = Round(ws.Shapes(i).Top, 0)
        r.Offset(, 2) = Round(ws.Shapes(i).Left, 0)
        Set r = r.Offset(1)
    End If
Next
[g:g].AdvancedFilter xlFilterCopy, [j1:j2], [L1], 1
Range("m2:m" & Range("L" & Rows.Count).End(xlUp).Row).Formula = "=countif(g:g,""=""&L2)"
m = WorksheetFunction.Max([h:h])
Set r = [h:h].Find(m, [h1], xlValues, xlWhole)
MsgBox "Chart width will be " & Round(ws.Shapes(r.Offset(, -2)).Width + m, 0) & " points."
[b:b].AdvancedFilter xlFilterCopy, [n1:n2], [r1], 1
Range("s2:s" & Range("r" & Rows.Count).End(xlUp).Row).Formula = "=countif(b:b,""=""&r2)"
End Sub

Is it supposed that there is any data in the cell F2, G1, F1 or H1 ?
 
Upvote 0
Sorry @Worf

I have run the macro get_data once the macro orga has been activated

In the sheet test1 I don't know why the macro get_data does not work. There is always an error message

See screenshot

https://www.dropbox.com/s/gpzypcf7rukk2u9/Error message.png?dl=0

And it seems that it be that line of code which is the problem

Code: 
[b:b].AdvancedFilter xlFilterCopy, [n1:n2], [r1], 1

It does not work either I select an entire row, an entire column, various cells or just one cell but the names of the shapes, top and left displays in the columns F, G and H...

Here below a screenshot of what I get when the macro get_data is activated

https://www.dropbox.com/s/smh8fz6wttg6g0l/dd.png?dl=0
 
Upvote 0
But I do understand what You mean, sorry At each time I have the bad habit to rush too quickly.

Like you wrote it. It's a start and a good start. I understand the the macro get_data gives the exact location of each specific shapes, next step: with the data in the column F, G and H, to succeed to locate the shapes a the exact location in order to get a chart well ordered.

Many thanks again for your time and your help on that issue

Kind regards
 
Upvote 0
Hello @Worf

I also work on an other chart and I try to add the other variable from column D, this time to be located above at the left of each specific shapes

See screenshot
https://www.dropbox.com/s/4tc6e8pbbjz5viq/top.png?dl=0

This time, as you can see, it goes from top to bottom.

Here is the code

Code: 
Dim colonne, débutOrg, f, forga, inth, intv, Tbl(), nSub DessineOrgaH()
   Set f = ActiveSheet
   Set forga = ActiveSheet
   Tbl = f.Range("A2:C" & f.[A65000].End(xlUp).Row).Value
n = UBound(Tbl)
   For Each s In forga.Shapes
    If s.Type = 17 Or s.Type = 1 Then s.Delete
   Next
   inth = 100
   intv = 80
   colonne = 0
   Set débutOrg = forga.Range("i5")
   créeShape Tbl(1, 1), 1, Tbl(1, 3), f.Cells(2, 1).Interior.Color
End Sub

Sub créeShape(parent, niv, Attribut, coul)
hauteurshape = 50
  
  largeurshape = 90
  
  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
    .Fill.ForeColor.RGB = coul
    .TextFrame.Characters(Start:=1, Length:=Len(parent)).Font.Color = vbRed
  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

I tried to adapt the code you gave me previously with the column D, with the code above but does not work. If you have any idea …
 
Upvote 0
Here is the code, and the lines in red are the ones I tried to adapt but does not work

Code: 
Dim colonne, débutOrg, f, forga, inth, intv, Tbl(), n
Sub DessineOrgaH()
   Set f = ActiveSheet
   Set forga = ActiveSheet
    [COLOR=#ff0000]Tbl = f.Range("a2:d" & f.[A65000].End(xlUp).Row).Value[/COLOR]
   n = UBound(Tbl)
   For Each s In forga.Shapes
    If s.Type = 17 Or s.Type = 1 Then s.Delete
   Next
   inth = 100
   intv = 80
   colonne = 0
   Set débutOrg = forga.Range("i5")
   créeShape Tbl(1, 1), 1, Tbl(1, 3), f.Cells(2, 1).Interior.Color
  
End Sub
Sub créeShape(parent, niv, Attribut, coul) ' procédure récursive
 
 
[COLOR=#ff0000]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[/COLOR]
 
 
  hauteurshape = 50
 
  largeurshape = 90
 
  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
    .Fill.ForeColor.RGB = coul
    .TextFrame.Characters(Start:=1, Length:=Len(parent)).Font.Color = vbRed
  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
 
Upvote 0
I did not give much explanations but I am glad you got the idea…
Test the version below on a copy of your workbook as it deletes sheet data.
I will be back during the week with code that actually does something…
We may discuss the second chart when the first one is formatted.

Code: 
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]Sub get_data()
Dim s As Shape, r As Range, i%, ws As Worksheet, m, lr%, dt As Worksheet
Set dt = Sheets("data1")
Set ws = Sheets("test1")
dt.Activate
Set r = [f2]
[f:o].ClearContents: [q:z].ClearContents
[g1] = "top": [j1] = "top": [o1] = [b1]: [n1] = "Level"
[f1] = "shape": [m1] = "# of shapes": [i1] = "Level"
[h1] = "left": [s1] = "# of sons"
For i = 1 To ws.Shapes.Count
    If Not ws.Shapes(i).Name Like "*aux" And Not ws.Shapes(i).Name Like "*conn" Then
        r = ws.Shapes(i).Name
        r.Offset(, 1) = Round(ws.Shapes(i).Top, 0)
        r.Offset(, 2) = Round(ws.Shapes(i).Left, 0)
        Set r = r.Offset(1)
    End If
Next
lr = Range("f" & Rows.Count).End(xlUp).Row
Range("i2:i" & lr).Formula = "=match(g2,$L$2:$L$10,0)"
dt.ListObjects.Add(xlSrcRange, Range("$F$1:$I$" & lr), , xlYes).Name = "Table2"
dt.ListObjects("Table2").TableStyle = "TableStyleMedium5"
[g:g].AdvancedFilter xlFilterCopy, [j1:j2], [L1], 1
Range("m2:m" & Range("L" & Rows.Count).End(xlUp).Row).Formula = "=countif(g:g,""=""&L2)"
m = WorksheetFunction.Max([h:h])
Set r = [h:h].Find(m, [h1], xlValues, xlWhole)
MsgBox "Chart width will be " & Round(ws.Shapes(r.Offset(, -2)).Width + m, 0) & " points."
[b:b].AdvancedFilter xlFilterCopy, [o1:o2], [r1], 1
Range("s2:s" & Range("r" & Rows.Count).End(xlUp).Row).Formula = "=countif(b:b,""=""&r2)"
lr = Range("m" & Rows.Count).End(xlUp).Row
dt.Range("n2:n" & lr).Formula = "=row()-1"
dt.ListObjects.Add(xlSrcRange, Range("$L$1:$n$" & lr), , xlYes).Name = "Table3"
dt.ListObjects("Table3").TableStyle = "TableStyleMedium4"
lr = Range("r" & Rows.Count).End(xlUp).Row
dt.ListObjects.Add(xlSrcRange, Range("$r$1:$s$" & lr), , xlYes).Name = "Table4"
dt.ListObjects("Table4").TableStyle = "TableStyleMedium7"
' initially look at row with more shapes
Set r = [m:m].Find(WorksheetFunction.Max([m:m]), [m1], xlValues, xlWhole)
[u1] = [i1]
[u2] = r.Offset(-1, 1)
' parents
dt.ListObjects("table2").Range.AdvancedFilter xlFilterCopy, [u1:u2], [v1], 0
' more code here in the near future...
End Sub[/FONT]
 
Upvote 0
You must log in or register to reply here.

Similar threads

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

Forum statistics

Threads
1,224,728
Messages
6,180,597
Members
452,988
Latest member
wcself81

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