Excel VBA Création d’organigramme sous forme d’arbre de décision

  ¨ Structure de la table de données

Pour ce faire nous se baser sur une table de donnée ayant la structure suivante :

* La colonne Code contient les indices comptables et/ou administratifs de la structure concernée.

* La colonne « Niveau » comporte le niveau hiérarchique de chaque structure. A chaque niveau est attribué un code appelé « NUM_NIVEAU ».

* La colonne « Libelle » contient les libellés de chaque structure.

* La colonne « Rattachement » indique la structure mère la structure en question.

¨ Modalité de création de l’organigramme

Il suffit de sélectionner la structure mère et ensuite cliquer sur créer organigramme, comme le détaille la figure ci-dessous :

Ainsi, pour l’exemple choisit, l’organigramme crée est le suivant :

¨ Fonctionnement du code VBA

La préparation de l’organigramme via le code VBA suit les étapes suivantes défalquées entre opérations manuelles et opérations préparées via le code VBA.

¨  Code pour Dessiner l’organigramme

Sub DESSINER_ORGANIGRAME()

 Dim ligne As Double

 Dim STR

 ligne = 1

 'Définition des paramètres de travail

 Set GRAPHE = Sheets("GRAPHE")

   Set donnee = Sheets("DONNEE")

   Tbl = donnee.Range("A2:E" & donnee.[A65000].End(xlUp).Row).Value

   CODE_STR = donnee.Cells(ActiveCell.Row, 1).Value

  

   n = UBound(Tbl)

 ' Supprimer les graphes déjà effectués dans les traitements précédents

  For Each s In GRAPHE.Shapes

    If s.Type = 17 Or s.Type = 1 Then s.Delete

   Next

 ' Définition des tailles des graphes à créer

  colonne = 0

   inth = 180

   intv = 32

  'Créer un shape pour la structure sélectionnée

   CREER_SHAPE CODE_STR, ligne

   'Boucle pour créer le shape pour les sous structure niveau 1

   For i = 1 To NBRE_DIRECT_RATTACHE(CODE_STR)

    ligne = ligne + i - 1

   STR = STR_RATTACHE_i(CODE_STR, i)

   CREER_SHAPE STR, ligne

   connect_str "C" & CODE_STR, "C" & STR 'Connecter les structures

   'Boucle pour créer le shape pour les sous structure niveau 2

   For j = 1 To NBRE_DIRECT_RATTACHE(STR)

     ligne = ligne + j - 1

     CREER_SHAPE STR_RATTACHE_i(STR, j), ligne

     connect_str "C" & STR, "C" & STR_RATTACHE_i(STR, j) 'Connecter les structures

   'Boucle pour créer le shape pour les sous structure niveau 3

     If j = NBRE_DIRECT_RATTACHE(STR) Then

          ligne = ligne - j

          Else

          ligne = ligne - j + 1

          End If

   Next

   ligne = ligne + NBRE_DIRECT_RATTACHE(STR) - i + 1

   Next

End Sub

¨ Fonction utilisée : Nombre de structures rattachées directement

Function NBRE_DIRECT_RATTACHE(ByVal CODE_STR As Double)

 'Retourne le nombre de structure rattaché

  Dim Plage As Range

       With Worksheets("donnee")   'en colonne "A" à partir de A2

       Set Plage = .Range(.Cells(2, 4), .Cells(.Rows.Count, 4).End(xlUp))

      End With

       

  NBRE_DIRECT_RATTACHE = Application.CountIf(Plage, CODE_STR)

 End Function

¨ Fonction utilisée : CREER_SHAPE

  Function CREER_SHAPE(ByVal Code_s As Long, ByVal ligne As Integer)

    Set débutOrg = GRAPHE.Range("b2")

 'ligne = ligne + i - 1

   hauteurshape = 25

  largeurshape = 160

  If ExisteShape("C" & Code_s) Then Exit Function

  GRAPHE.Shapes.AddShape(msoShapeFlowchartAlternateProcess, 10, 10, largeurshape, Hauteur(Code_s)).Name = "C" & Code_s

  GRAPHE.Shapes("C" & Code_s).Line.ForeColor.SchemeColor = 1

  txt = STR(Code_s)

  With GRAPHE.Shapes("C" & Code_s)

    .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(txt)).Font.Bold = True

    .Fill.ForeColor.RGB = colorer(Code_s)

    .TextFrame.Characters(Start:=1, Length:=Len(txt)).Font.Color = vbBlack

  End With

  GRAPHE.Shapes("C" & Code_s).Left = débutOrg.Left + (NIV_STR(Code_s) - NIV_STR(CODE_STR)) * inth

  GRAPHE.Shapes("C" & Code_s).Top = débutOrg.Top + intv * ligne

 End Function

¨ Fonction utilisée : Connecter les structures dessinées

La principale fonctionnalité de cette fonction est « .Shapes.AddConnector » destinée à connecter deux shapes :

 Function connect_str(ByVal cPere As String, ByVal cFils As String)

 Dim coul_ligne

 coul_ligne = Sheets("DONNEE").Range("I2").Value

      GRAPHE.Shapes.AddConnector(msoConnectorElbow, 100, 100, 100, 100).Name = cPere & cFils

      GRAPHE.Shapes(cPere & cFils).Line.ForeColor.SchemeColor = coul_ligne

      GRAPHE.Shapes(cPere & cFils).ConnectorFormat.BeginConnect GRAPHE.Shapes(cPere), 4

      GRAPHE.Shapes(cPere & cFils).ConnectorFormat.EndConnect GRAPHE.Shapes(cFils), 2

 End Function

¨ Fonction utilisée : retourner les structures rattachées à chaque structure

Function STR_RATTACHE_i(ByVal STR_C As Double, ByVal rang As Integer)

 'Renvoi les ligne des differentes structure rattaché

 Set f = Sheets("DONNEE")

 Dim lig_, col_ As Double

 Dim fil() As Double

 Dim Plage As Range

  Dim Cel As Range

      With Worksheets("donnee")

     'en colonne "A" à partir de A2

       Set Plage = .Range(.Cells(2, 4), .Cells(.Rows.Count, 4).End(xlUp))

      End With

If rang <= NBRE_DIRECT_RATTACHE(STR_C) Then

 i = 0

 

        For Each Cel In Plage

        lig_ = Cel.Row

        col_ = Cel.Column

             If f.Cells(lig_, 4).Value = STR_C Then

             i = i + 1

              ReDim Preserve fil(i)

              fil(i) = lig_ 'f.Cells(lig_, 1).Value

             End If

        Next

  STR_RATTACHE_i = f.Cells(fil(rang), 1).Value

  Else

  MsgBox "Rang : " & rang & " Supérieur à la taille : " & NBRE_DIRECT_RATTACHE(STR_C)

  End If

 End Function

¨ Fonction utilisée : colorer les shapes en fonction du niveau de la structure

Function colorer(ByVal Code_s As Long)

    Select Case TYP_STR(Code_s)

   Case "CENTRAL"

   colorer = donnee.Cells(2, 7).Interior.Color

   Case "DIRECTION"

     colorer = donnee.Cells(3, 7).Interior.Color

   Case "DIVISION"

     colorer = donnee.Cells(4, 7).Interior.Color

      Case "DG"

     colorer = donnee.Cells(5, 7).Interior.Color

     Case "SERVICE"

     colorer = donnee.Cells(6, 7).Interior.Color

    

   End Select

 End Function

¨ Fonction utilisée : déterminer le type structure

Function TYP_STR(ByVal CODE_STR As Double)

  Dim Plage As Range

       With Worksheets("donnee")   'en colonne "A" à partir de A2

       Set Plage = .Range(.Cells(2, 1), .Cells(.Rows.Count, 2).End(xlUp))

      End With

       

  TYP_STR = WorksheetFunction.VLookup(CODE_STR, Plage, 2, False)

 End Function

¨ Fonction utilisée : déterminer la structure en fonction de son code

Function STR(ByVal CODE_STR As Double)

  Dim Plage As Range

       With Worksheets("donnee")   'en colonne "A" à partir de A2

       Set Plage = .Range(.Cells(2, 1), .Cells(.Rows.Count, 3).End(xlUp))

      End With

       

  STR = WorksheetFunction.VLookup(CODE_STR, Plage, 3, False)

 End Function