Dim colonne, débutOrg, forga, inth, intv, Tbl(), n
Sub DessineOrga()
Set forga = Sheets("orga")
Set f = Sheets("bd")
Tbl = f.Range("A2:D" & f.[A65000].End(xlUp).Row).Value
n = UBound(Tbl)
For i = 2 To n
If Len(Tbl(i, 1)) = 1 Then Tbl(i, 4) = "0" Else p = InStrRev(Tbl(i, 1), "."): Tbl(i, 4) = Left(Tbl(i, 1), p - 1)
Next i
For Each s In forga.Shapes
If s.Type = 17 Or s.Type = 1 Then s.Delete
Next
inth = 50
intv = 40
colonne = 0
Set débutOrg = forga.Range("a4")
créeShape Tbl(1, 1), 1, Tbl(1, 2), Tbl(1, 3)
End Sub
Sub créeShape(parent, niv, Attribut, attribut2) ' procédure récursive
hauteurshape = 30
largeurshape = 90
colonne = colonne + 1
forga.Shapes.AddTextbox(msoTextOrientationHorizontal, 10, 10, largeurshape, hauteurshape).Name = parent
forga.Shapes(parent).Line.ForeColor.SchemeColor = 22
txt = Attribut & vbLf & attribut2
With forga.Shapes(parent)
.TextFrame.Characters.Text = txt
.TextFrame.Characters(Start:=1, Length:=1000).Font.Size = 8
.TextFrame.Characters(Start:=1, Length:=Len(Attribut)).Font.Bold = True
.TextFrame.Characters(Start:=1, Length:=Len(Attribut)).Font.ColorIndex = 3
.Fill.ForeColor.RGB = RGB(255, 255, 255)
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, 4)
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, 4) = parent Then créeShape Tbl(i, 1), niv + 1, Tbl(i, 2), Tbl(i, 3)
Next i
End Sub
Dim n, ligne, debOrg, Tbl()
Sub DessineOrgaTxt()
Set f = Sheets("bd")
Set forga = Sheets("orgaTexte")
Set debOrg = forga.[A2]
debOrg.Resize(20, 7).Clear
Tbl = f.Range("A2:D" & f.[A65000].End(xlUp).Row).Value
n = UBound(Tbl)
For i = 2 To n
If Len(Tbl(i, 1)) = 1 Then
Tbl(i, 4) = "0"
Else
If IsNumeric(Right(Tbl(i, 1), 2)) Then Tbl(i, 4) = Left(Tbl(i, 1), Len(Tbl(i, 1)) - 2) Else Tbl(i, 4) = Left(Tbl(i, 1), Len(Tbl(i, 1)) - 1)
End If
Next i
ligne = 0: Ecrit Tbl(1, 1), 1, Tbl(1, 2)
ligne = 0: Présentation Tbl(1, 1), 1
End Sub
Sub Ecrit(parent, niv, txt) ' procédure récursive
ligne = ligne + 1
debOrg.Offset(ligne, niv) = txt
debOrg.Offset(ligne, niv).Borders(xlEdgeLeft).Weight = xlThin
debOrg.Offset(ligne, niv).Borders(xlEdgeBottom).Weight = xlThin
For i = 1 To n
If Tbl(i, 4) = parent Then Ecrit Tbl(i, 1), niv + 1, Tbl(i, 2)
Next i
End Sub
Sub Présentation(parent, niv) ' procédure récursive
ligne = ligne + 1
Fin = debOrg.Offset(ligne, niv).End(xlDown).Row
If Fin < 100 Then
For i = ligne To Fin - debOrg.Row
debOrg.Offset(i, niv).Borders(xlEdgeLeft).Weight = xlThin
Next i
End If
For i = 1 To n
If Tbl(i, 4) = parent Then Présentation Tbl(i, 1), niv + 1
Next i
End Sub
(re) Bonsoir à tous,
Bon, voici normalement la bonne version
Edit: j'ai fait "dans le compliqué et tordu", BOISGONTIER l'a fait "dans le simple et concis".
A direction generale 1 Cmt1
AA Direction 1 Cmt2
AA01 service Cmt3
B direction generale 2 Cmt4
BA direction2 Cmt5
BA01 service 2 Cmt6
BA02 service 2x Cmt7
Bonjour;
Ma dernière version avec les Shapes comme demandé initialement, avec la possibilité de seulement mettre à jour les textes des pavés existants.