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
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
Organigramme photo
Autre version avec Shapes (ne fonctionne pas sur Excel 2003)
Organigramme hiérarchique dynamique d'une base de données avec shapes
OrganigrammeH
OrganigrammeH Liens Sup
Organigramme Tph
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
Autre version avec regroupements de noms au 3e niveau
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
TreeViewHiérarchie
feuille
Treeview nomenclatureSimple
Treeview nomenclature
Treeview nomenclature2
Treeview nomenclature
3
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
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.
Création d'un ID en fonction d'un niveau
Crée ID
niveau
Crée ID niveau2
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.
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
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
Trace
organigrammes multiples chapeau
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)
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
Création d'un ID hiérarchique
Dim TblBD(), NBLig
Sub CreeID()
NBLig = [Tableau1].Rows.Count
ReDim TblBD(1 To NBLig, 1 To 2)
For i = 1 To NBLig
TblBD(i, 1) = [Tableau1].Item(i, 1)
TblBD(i, 2) = [Tableau1].Item(i, 1).IndentLevel + 1
Next i
TblBD(1, 2) = "1-1-"
IDPrec = TblBD(1, 2)
For i = 2 To NBLig
niv = TblBD(i, 2)
If nivprecedent = niv Then
tmp = maxi2(niv)
x = Right(tmp, 2)
TblBD(i, 2) = Left(tmp, niv * 2) &
Left(x, 1) + 1 & "-"
Else
If niv > nivprecedent Then
tmp = IDPrec
TblBD(i, 2) = tmp
& "1-"
Else
tmp = maxi2(niv)
x = Right(tmp, 2)
TblBD(i, 2) = Left(tmp,
Len(tmp) - 2) & Left(x, 1) + 1 & "-"
End If
End If
nivprecedent = niv
IDPrec = TblBD(i, 2)
Next i
[b2].Resize(NBLig, 1) = Application.Index(TblBD, , 2)
End Sub
Function maxi(niv)
For j = 1 To NBLig
If Len(TblBD(j, 2)) = niv * 2 Then
If TblBD(j, 2) > mx
Then mx = TblBD(j, 2)
End If
Next j
maxi = mx
End Function
Function maxi2(niv)
For j = 1 To NBLig
If Len(TblBD(j, 2)) = niv * 2 + 2 Then
If TblBD(j, 2) > mx Then mx = TblBD(j,
2)
End If
Next j
maxi2 = mx
End Function