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

 

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

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
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

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

 

 

 


Exemples

jb-Organigramme
jb-TreeViewExemples
Arborescence Répertoire Shapes