Doflamingo
Board Regular
- Joined
- Apr 16, 2019
- Messages
- 238
Dear all,
I try to find a way to rearrange a structure chart
Here the current image I get
https://www.dropbox.com/s/25sxfbbhv1vb9pj/CUURENT DIISPLAY.png?dl=0
Here what I would like
https://www.dropbox.com/s/pquidh4eul69mi2/Rearrange structure chart.png?dl=0
Sheet 1, In the range A2, I put the name of the firm LVMH, the holder of all the subsidiaries.
And then in the range A3 to A7, I put the subsidiary of LVMH which are Château d'Yquem, Veuve Cliquot, Louis Vuitto, Sephora, Cheval Blanc Courchevel and then in the range B3 to B7, I put the word LVMH given that LVMH is the holder of those subsidiary. In the ranges A8 to A10, I put the word, Guerlain, Givenchy Parfums and Christian Dior and in the range B8 to B10, I put the word Sephora given that Sephora is the holder of those subsidiary… the code works like that
Here is the code
Any ideas ?
I try to find a way to rearrange a structure chart
Here the current image I get
https://www.dropbox.com/s/25sxfbbhv1vb9pj/CUURENT DIISPLAY.png?dl=0
Here what I would like
https://www.dropbox.com/s/pquidh4eul69mi2/Rearrange structure chart.png?dl=0
Sheet 1, In the range A2, I put the name of the firm LVMH, the holder of all the subsidiaries.
And then in the range A3 to A7, I put the subsidiary of LVMH which are Château d'Yquem, Veuve Cliquot, Louis Vuitto, Sephora, Cheval Blanc Courchevel and then in the range B3 to B7, I put the word LVMH given that LVMH is the holder of those subsidiary. In the ranges A8 to A10, I put the word, Guerlain, Givenchy Parfums and Christian Dior and in the range B8 to B10, I put the word Sephora given that Sephora is the holder of those subsidiary… the code works like that
Here is the code
Code:
Dim colonne, débutOrg, f, forga, inth, intv, Tbl(), n
Sub DessineOrga()
Set forga = Sheets("sheet2")
Set f = Sheets("sheet1")
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 = 70
intv = 60
colonne = 0
Set débutOrg = forga.Range("c4")
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
hauteurshape = 48
largeurshape = 85
colonne = colonne + 1
forga.Shapes.AddShape(msoShapeFlowchartAlternateProcess, 10, 10, largeurshape, hauteurshape).Name = parent
forga.Shapes(parent).Line.ForeColor.SchemeColor = 0
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 = 0
.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 = 0
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
Any ideas ?