Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2010 Organigramme automatique non centré

fablog

XLDnaute Occasionnel
Bonjour,

J'ai un souci avec la création automatique d'organigrammes avec Excel. J'ai utilisé le code VBA de Boisgontier provenant de ce fichier.
Quand j'utilise son fichier en activant la macro, je n'ai pas un organigramme qui se centre en fonction du niveau supérieur, mais cela fait une sorte d'alignement à droite. Quand j'intègre beaucoup d'éléments à cet organigramme, cela me fait un tableau très étiré en largeur donc peu lisible.

Je ne sais pas programmer en VBA même si je commence à m'y retrouver. Pourriez-vous m'aider à modifier les macros ci-dessous pour centrer l'organigramme svp?

VB:
Dim colonne, débutOrg, forga, inth, intv, Tbl(), n
Sub DessineOrgaClic()
  Set forga = Sheets("orga")
  Set f = Sheets("bd")
  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
  Set débutOrg = forga.Range("A10")
  colonne = 0
  inth = 55
  intv = 35
  créeShape Tbl(1, 1), 1, Tbl(1, 3)
End Sub
Sub créeShape(parent, niv, Attribut) ' procédure récursive
  hauteurshape = 20
  largeurshape = 50
  forga.Shapes.AddTextbox(msoTextOrientationHorizontal, 10, 10, largeurshape, hauteurshape).Name = parent
  forga.Shapes(parent).Line.ForeColor.SchemeColor = 22
  txt = parent
  With forga.Shapes(parent)
   .TextFrame.Characters.Text = txt
   .TextFrame.Characters(Start:=1, Length:=1000).Font.Size = 7
   .OnAction = "detail"
  End With
  colonne = colonne + 1
  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)
  Next i
End Sub
Sub detail()
  On Error Resume Next
  For Each s In ActiveSheet.Shapes
     s.Fill.ForeColor.RGB = RGB(255, 255, 255)
  Next s
  On Error GoTo 0
  Set fbd = Sheets("bd")
  s = Application.Caller
  Set result = fbd.[a:a].Find(what:=s)
  [d2] = result
  [d3] = result.Offset(, 1)
  [d4] = result.Offset(, 2)
  [d5] = result.Offset(, 3)
  [d6] = result.Offset(, 4)
  ActiveSheet.Shapes(s).Fill.ForeColor.RGB = RGB(255, 0, 0)
End Sub

Merci et bonne journée!

Fabien
 
Dernière édition:
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…