Add New Variable to Shapes

Some videos you may like

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.

Doflamingo

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

Worf

Well-known Member
Joined
Oct 30, 2011
Messages
3,876
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
 

Doflamingo

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

Doflamingo

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

Doflamingo

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

Doflamingo

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

Doflamingo

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

Doflamingo

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

Worf

Well-known Member
Joined
Oct 30, 2011
Messages
3,876
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]
 

Watch MrExcel Video

Forum statistics

Threads
1,089,873
Messages
5,410,902
Members
403,333
Latest member
SH2020

This Week's Hot Topics

Top