Arborescence/Récursivité

Accueil

Tracé d'organigramme dynamique
Création d'une arborescence de répertoires
Organigramme horizontal
Organigramme photo
Organigramme hiérarchique avec shapes
Généalogie avec shapes à partir d'une base de données
Nomenclature avec shapes
TreeView Hiérarchique
Tri quick-sort
Module de classe Arbre
Tri des relations père/Fils
Organigrammes multiples
Diagramme

 

Tracé d'organigramme hiérarchique automatique d'une base de données

Organigramme Simple
Organigramme Simple Commentaire
Organigramme Simple 2
Nomenclature
Nomenclature2

Dim n, ligne, debOrg, Tbl()
Sub organigramme()
  Tbl = Range("A2:B" & [A65000].End(xlUp).Row).Value
  Set debOrg = [d8]
  debOrg.Resize(25, 25).Clear
  n = UBound(Tbl)
  ligne = 0: Ecrit Tbl(1, 1), 1
  ligne = 0: Présentation Tbl(1, 1), 1
End Sub

Sub Ecrit(parent, niv) ' procédure récursive
  ligne = ligne + 1
  debOrg.Offset(ligne, niv) = parent
  debOrg.Offset(ligne, niv).Borders(xlEdgeLeft).Weight = xlThin
  debOrg.Offset(ligne, niv).Borders(xlEdgeBottom).Weight = xlThin
  For i = 1 To n
    If Tbl(i, 2) = parent Then Ecrit Tbl(i, 1), niv + 1
  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, 2) = parent Then Présentation Tbl(i, 1), niv + 1
  Next i
End Sub

Autre exemple

Hiérarchie

Création d'une arborescence de répertoires

Crée d'une Arborescence de répertoires
Transforme organigramme en BD
Arborescence Répertoire Shapes

Dim n, ligne, Tbl(), RepNiv(1 To 6)
Sub CreeArboRepertoire()
  Tbl = Range("A2:B" & [A65000].End(xlUp).Row).Value
  n = UBound(Tbl)
  niv = 1
  CréeRep Tbl(1, 1), niv
End Sub

Sub CréeRep(parent, niv)     ' procédure récursive
  chemin = ""
  RepNiv(niv) = parent
  For i = 1 To niv
  chemin = chemin & RepNiv(i) & "\"
  Next i
  MkDir chemin
  For i = 1 To n
    If Tbl(i, 2) = parent Then CréeRep Tbl(i, 1), niv + 1
  Next i
End Sub

Arborescence des sous-répertoires d'un répertoire avec shapes

Peut être imprimé.

Arborescence Répertoire Sous répertoire Shapes

 

Organigramme dynamique Horizontal d'une base de données

OrganigrammeHorizontal

Organigramme photo

OrganigrammePhoto

Autre version avec Shapes (ne fonctionne pas sur Excel 2003)

OrganigrammePhoto2

Organigramme hiérarchique dynamique d'une base de données avec shapes

OrganigrammeH
OrganigrammeH Liens Sup
OrganigrammeH Matricule
Branche Organigramme H
OrganigrammeHClic
OrganigrammeH Survol
OrganigrammeV
OrganigrammeV Casse
Organigramme Société
Organigramme Hiérarchie
Organigramme Hiérarchie1
Organigramme Hiérarchie1Vertical
Crée numéro arborescence

Dim colonne, débutOrg, f, forga, inth, intv, Tbl(), n
Sub DessineOrga()
  Set forga = Sheets("orgaShapes")
  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
  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 = 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
    .TextFrame.Characters(Start:=1, Length:=Len(parent)).Font.ColorIndex = 3
    .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 = 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

Avec photo

Organigramme Photo
Organigramme PhotoArrièrePlan

Photo en arrière-plan

 

Autre version avec regroupements de noms au 3e niveau

Organigramme

Généalogie avec shapes

Avec la seconde version, on visualise la branche choisie de l'arbre généalogique.

Organigramme Généalogie
Organigramme Généalogie branche choisie

Ci dessous, on obtient l'arbre généalogique des ascendants pour la ligne choisie dans la base de données.

Arbre généalogique (pedigree) à partir d'une base de données

Nomenclature avec shapes

NomenclatureV
NomenclatureH
NomenclatureEnsemble
Nomenclature Formule

Nomenclature2
NomenclatureCalculPrix
TreeviewNomenclature

TreeView hiérarchique

L'objet TreeView permet de visualiser une arborescence dans un formulaire.

TreeViewHiérarchie
Treeview nomenclatureSimple
Treeview nomenclature
Treeview nomenclature2
Treeview généalogie
Treeview Arborescence répertoire

La syntaxe pour créer un noeud est:
xxx.Nodes.Add(noeud_père,twchild,création_noeud_courant,libellé_noeud)


Dim tw As MSComctlLib.TreeView
Dim Tbl, n

Private Sub UserForm_Initialize()
  Tbl = Range("A2:E" & [A65000].End(xlUp).Row).Value
  pere = Tbl(1, 1)
  Set tw = Me.MonArbre
  n = UBound(Tbl)
  tw.Nodes.Add(, , "NoeudMat" & pere, Tbl(1, 3)).Expanded = True ' Racine arbre
  Fils pere, 1
End Sub

Sub Fils(parent, niv) ' procédure récursive
  For i = 2 To n
    cd = Tbl(i, 2)
    If cd = parent Then
      tw.Nodes.Add("NoeudMat" & parent, tvwChild, "NoeudMat" & Tbl(i, 1), Tbl(i, 1)).Expanded = True
      Fils Tbl(i, 1), niv + 1
    End If
  Next i
End Sub

Private Sub MonArbre_NodeClick(ByVal Node As MSComctlLib.Node)
  If Left(Node.Key, 8) = "NoeudMat" Then
    Me.Nom = Application.VLookup(Mid(Node.Key, 9), Tbl, 1, False)
    Me.Sup = Application.VLookup(Mid(Node.Key, 9), Tbl, 2, False)
    Me.Service = Application.VLookup(Mid(Node.Key, 9), Tbl, 3, False)
    Me.Cmt = Application.VLookup(Mid(Node.Key, 9), Tbl, 4, False)
    tmp = Application.VLookup(Mid(Node.Key, 9), Tbl, 5, False)
    If tmp <> "" Then
      Me.Image1.Picture = LoadPicture("c:\photos\" & tmp & ".jpg")
    Else
      Me.Image1.Picture = LoadPicture
    End If
  End If
End Sub

Création d'un ID hiérarchique

A partir de la relation père/fils on crée un ID hiérarchique

Crée ID Hiérarchique

fils père  id
AA            1.
BB AA       1.1.
CC AA      1.2.
DD BB      1.1.1.
EE DD       1.1.1.1.
FF DD       1.1.1.2.
GG AA      1.3.
HH BB       1.1.2.
II GG        1.3.1.
JJ CC        1.2.1.

Module de classe Arborescence/Organigramme d'une base de données

Classe ArbreTableau
ArbreTableau
Classe ArbreDictionary

Sub DessineBrancheArbre()
  Set a = New Arbre
  a.Ajout = "aa,,Attribut1"
  a.Ajout = "bb,aa,Attribut2"
  a.Ajout = "cc,aa,Attribut3"
  a.Ajout = "dd,aa,Attribut4"
  a.Ajout = "ee,bb,Attribut5"
  a.Ajout = "ff,bb,Attribut6"
  a.Ajout = "gg,dd,Attribut7"
  a.Ajout = "hh,ee,Attribut8"
  a.Ajout = "ii,ee,Attribut9"
  a.Ajout = "jj,hh,Attribut10"
  a.Ajout = "kk,hh,Attribut11"
  a.DessineBrancheShapes = "aa,feuil1"
  a.DessineBrancheShapes = "bb,feuil2"
  Sheets("feuil1").Select
End Sub

Sub ArbreBD()
  Set a = New Arbre
  Set f = Sheets("bd")
  For i = 2 To f.[A65000].End(xlUp).Row
     a.Ajout = f.Cells(i, 1) & "," & f.Cells(i, 2) & "," & f.Cells(i, 3)
  Next i
  a.DessineBrancheShapes = "aa,feuil1"
  a.DessineBrancheShapes = "bb,feuil2"
End Sub

Module de classe

Private Tbl(1 To 100, 1 To 4)
Private n, branche, débutOrg, fbd, inth, intv, colonne

Public Property Let Ajout(FilsPèreAttribut)
a = Split(FilsPèreAttribut, ",")
n = n + 1
Tbl(n, 1) = a(0): Tbl(n, 2) = a(1): Tbl(n, 3) = a(2)
End Property

Public Property Let DessineBrancheShapes(pèreFeuille)
  a = Split(pèreFeuille, ",")
  Set fbd = Sheets(a(1))
  For Each s In fbd.Shapes
    If s.Type = 17 Or s.Type = 1 Then s.Delete
  Next s
  tmp = a(0)
  Set débutOrg = fbd.Range("c4")
  colonne = 0
  inth = 60
  intv = 40
  créeShape tmp, 1, Attribut(tmp)
End Property

Public Property Get affiche()
  tmp = ""
  For p = 1 To n
    If Tbl(p, 1) <> "" Then tmp = tmp & "Fils:" & Tbl(p, 1) & " - père:" & Tbl(p, 2) & vbLf
  Next p
  affiche = tmp
End Property

Public Property Get liste()
  tmp = ""
  For p = 1 To n
    If Tbl(p, 1) <> "" Then tmp = tmp & Tbl(p, 1) & "," & Tbl(p, 2) & "," & Tbl(p, 3) & ":"
  Next p
  liste = Left(tmp, Len(tmp) - 1)
End Property

Public Property Get Père(Fils)
  For i = 1 To n
     If Tbl(i, 1) = Fils Then Père = Tbl(i, 2)
  Next i
End Property

Public Property Get Attribut(Fils)
  For i = 1 To n
    If Tbl(i, 1) = Fils Then Attribut = Tbl(i, 3)
  Next i
End Property

Sub créeShape(parent, niv, Attribut) ' procédure récursive
  hauteurshape = 30
  largeurshape = 50
  colonne = colonne + 1
  fbd.Shapes.AddTextbox(msoTextOrientationHorizontal, 10, 10, largeurshape, hauteurshape).Name = parent
  fbd.Shapes(parent).Line.ForeColor.SchemeColor = 22
  txt = parent & vbLf & Attribut
  With fbd.Shapes(parent)
   .TextFrame.Characters.Text = txt
   .TextFrame.Characters(Start:=1, Length:=1000).Font.Size = 8
   .TextFrame.Characters(Start:=1, Length:=Len(parent)).Font.Bold = True
   .Fill.ForeColor.RGB = RGB(255, 255, 255)
   .TextFrame.Characters(Start:=1, Length:=Len(parent)).Font.Color = vbRed
   .OnAction = "detail"
  End With
  fbd.Shapes(parent).Left = débutOrg.Left + inth * colonne
  fbd.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)
     fbd.Shapes.AddConnector(msoConnectorElbow, 100, 100, 100, 100).Name = parent & "c"
     fbd.Shapes(parent & "c").Line.ForeColor.SchemeColor = 22
     fbd.Shapes(parent & "c").ConnectorFormat.BeginConnect fbd.Shapes(shapePère), 3
     fbd.Shapes(parent & "c").ConnectorFormat.EndConnect fbd.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

Tri Quick-Sort

Le principe est le suivant:

On répartit la suite de nombres à trier de telle sorte que tous les éléments inférieurs à un élément de référence (36 sur l'exemple) soient à gauche de celui-ci et que tous ceux qui lui sont supérieurs à sa droite.

[70 61 16 48 29 18 59 36 3 70 3 22 39 30 58 10] <- Avant
                                  ¦
             Elément médian de référence
                             ¦
[3 30 16 22 29 18] 36 [70 59 48 39 59 61 58 70] <- Après

               ¦                              ¦
Eléments<36                   Eléments>36

Tous les éléments de l'ensemble de droite sont supérieurs à ceux de l'ensemble de gauche. En procédant de la même façon sur les 2 sous-ensembles générés,on obtient 4 sous-ensembles ordonnés entre eux. Lorsque la taille des ensembles devient égale à 1,les nombres sont triés.

Choix de l'élément de référence:

Pour obtenir des sous-ensembles de tailles équilibrées,il faut que l'élément de référence ne soit ni trop petit,ni trop grand.

La méthode classique consiste à choisir l'élément de référence parmi 3 éléments:Ceux de gauche,du milieu et de droite.
Nous observons qu'en choisissant l'élément de référence au milieu de la liste à traiter, le temps de tri est le même.

Remarques:

-Si la liste est déja triée,le temps de tri n'augmente pas lorsque l'élément de référence est choisi au milieu,ce qui n'est pas le cas lorsqu'il est choisi à gauche.
-Le programme proposé est récursif.

TriQuick-Sort.xls

Sub essai()
  Dim temp(10000) As Double
  For i = 1 To 10000
     temp(i) = Rnd
  Next i
  t = Timer
  Call tri(temp, 1, 10000)
  MsgBox Timer - t
End Sub

Sub tri(a() As Double, gauc, droi) ' Quick sort
   ref = a((gauc + droi) \ 2)
   g = gauc: d = droi
   Do
      Do While a(g) < ref: g = g + 1: Loop
      Do While ref < a(d): d = d - 1: Loop
        If g <= d Then
           temp = a(g): a(g) = a(d): a(d) = temp
           g = g + 1: d = d - 1
        End If
    Loop While g <= d
    If g < droi Then Call tri(a, g, droi)
    If gauc < d Then Call tri(a, gauc, d)
End Sub

Gérer la récursivité avec une pile sans procédure récursive

Récursif

Sub essai()
  Dim pile(1 To 20)
  nr = Application.CountA([pere])
  niv = 1
  pile(niv) = 0
  mpere = "A"
  ligne = 2
  col = 5
  Cells(ligne, col) = mpere
  Cells(ligne, col).Borders(xlEdgeBottom).Weight = xlThin
  ligne = ligne + 1
  témoinFin = False
  Do While Not témoinFin
    '--- recherche fils de mpere
    p = pile(niv) + 1
    trouvé = False
    Do While p <= nr And Not trouvé
      If Range("pere")(p) = mpere Then trouvé = True Else p = p + 1
    Loop
    If Not trouvé Then
      If niv = 1 Then
        témoinFin = True
      Else
        niv = niv - 1
        mpere = Range("pere")(pile(niv)) ' reprise au niveau inférieur
      End If
   Else
      pile(niv) = p  ' mémorisation du dernier traité
      niv = niv + 1 ' nouveau niveau
      pile(niv) = 0
      Cells(ligne, col + niv - 1).Borders(xlEdgeLeft).Weight = xlThin
      Cells(ligne, col + niv - 1) = Range("fils")(p)
      Cells(ligne, col + niv - 1).Borders(xlEdgeBottom).Weight = xlThin
      mpere = Range("fils")(p)
      ligne = ligne + 1
    End If
  Loop
End Sub

Tri relations père/fils

On veut trier les relations père/fils: pour chaque père, on veut les fils de niveau1,niveau2,niveau3,..

Conversion père fils
Conversion père fils couleur
Conversion père fils couleur2

Dim n, ligne, debOrg, Tbl()
Sub Conversion()
  Tbl = Range("A2:B" & [A65000].End(xlUp).Row).Value
  Set debOrg = [d1]
  debOrg.Offset(1).Resize(25, 2).ClearContents
  n = UBound(Tbl)
  ligne = 0
  For k = 1 To n ' Recherche des pères
     If Tbl(k, 2) = "" Then Ecrit Tbl(k, 1), 1, Tbl(k, 2)
  Next k
End Sub

Sub Ecrit(parent, niv, comp) ' procédure récursive
  ligne = ligne + 1
  debOrg.Offset(ligne) = parent: debOrg.Offset(ligne, 1) = comp
  For i = 1 To n
     If Tbl(i, 2) = parent Then Ecrit Tbl(i, 1), niv + 1, Tbl(i, 2)
  Next i
End Sub

Tracé d'oganigrammes multiples


Trace organigrammes multiples
Trace organigrammes multiples identifiants
Trace organigrammes multiples 2

Ci dessous, 3 organigrammes sont définis par les relations père/fils: America, Europe, Africa.

Dim ligne, débutOrg, f, forga, inth, intv, Tbl(), n, OrgaN
Sub DessineOrga()
  Set forga = Sheets("orga")
  Set f = Sheets("bd")
  Tbl = f.Range("A2:D" & f.[A65000].End(xlUp).Row).Value
  For i = 1 To UBound(Tbl): Tbl(i, 4) = f.Cells(i + 1, 1).Interior.Color: Next i
  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("a1")
  inth = 35
  intv = 33
  OrgaN = 0
  For k = 1 To n ' Recherche des pères
     If Tbl(k, 2) = "" Then
        ligne = 0
        Set débutOrg = forga.Range("a1").Offset(, OrgaN * 5)
        créeShape Tbl(k, 1), 1, Tbl(k, 3), Tbl(k, 4)
        OrgaN = OrgaN + 1
      End If
   Next k
End Sub

Sub créeShape(parent, niv, Attribut, coul) ' procédure récursive
   hauteurshape = 30
   largeurshape = 50
   ligne = ligne + 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 = 5
     .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 + niv * inth
    forga.Shapes(parent).Top = débutOrg.Top + intv * ligne
    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), 2
        End If
        If Tbl(i, 2) = parent Then créeShape Tbl(i, 1), niv + 1, Tbl(i, 3), Tbl(i, 4)
    Next i
End Sub

Diagramme

A chaque fonction de niveau1 sont associées des fonctions de niveau0 (fils) et des fonctions (pères) de niveau 2

3 types de diagramme:

-Pour une fonction de niveau 1, on a les fils (niveau 0) et les pères (niveau 2)
-Pour une fonction de niveau 2, on a tous ses fils (niveau 1 & Niveau 0)
-Pour une fonction de niveau 0, on a tous ses ascendants (niveau 1 & Niveau 2)

Diagramme

Fonction de Niveau1, ses fils et pères

Fonction de Niveau 2 et ses fils niveau 1 et niveau 0

Niveau 0 et ses pères niveau 1 et niveau 2