Accueil

Module de classe
Avantages de la programmation objet
Module de classe Liste
Module de classe Base de données
Module de classe Tableau
Module de classe DictionnaireMac pour Excel Mac
Module de classe Dictionnaire avec Tri
Simulation de ArrayList et SortedList
Module de classe Arbre

Modules de classe

On peut ajouter aux classes d'objets Excel ses propres classes.
Un objet est l'association de données et de fonctions.

Sur l'exemple, nous avons crée une classe Rectangle dans un module de classe:
-Rectangle est une classe (virtuel)
-'a' est un objet de la classe Rectangle (on instancie la classe Rectangle)

Sub essai
  Set a = New Rectangle                 ' Nouvel objet 'a' classe Rectangle
  a.hauteur = 20                            ' Propriété hauteur
  a.largeur = 30
  MsgBox a.surface                        ' Propriété surface 
  MsgBox a.perimetre                     ' Propriété périmètre
End sub

Classe Rectangle

Avantages de la programmation objet (POO)

-On initialise l'objet 'a' avec des valeurs (hauteur et largeur sur l'exemple). Celles ci sont mémorisées dans l'objet.
-Lorsque que l'on appelle une fonction (propriété) de l'objet (surface ou périmètre), il n'est plus nécessaire de lui passer des paramètres comme on le fait sans programmation objet.
-La classe gère elle même certains paramètres qui deviennent donc transparents au programmeur d'application.

D'une façon générale, les objets ont :
-des propriétés (valeurs) que l'on peut récupérer ou modifier.
-des méthodes qui agissent sur l'objet.

Création d’une classe

- Insertion/Module de classe
- Nommer le module de Classe Rectangle (Le nom du module représente le nom de la classe)

Private xhauteur As Double
Private xlargeur As Double

Public Property Let hauteur(phauteur)
  xhauteur = phauteur
End Property

Public Property Let largeur(plargeur)
  xlargeur = plargeur
End Property

Public Property Get hauteur()
  hauteur = xhauteur
End Property

Public Property Get largeur()
  largeur = xlargeur
End Property

Public Property Get surface()
  surface = xlargeur * xhauteur
End Property

Public Property Get perimetre()
  perimetre = (xlargeur + xhauteur) * 2
End Property

Classe Liste

La classe Liste gère des listes de couples clé+item.
Elle permet d'ajouter, supprimer et trier ces couples.

ClasseListe      

Méthodes et propriétés de la classe Liste

Sub essaiClasseListe()
  Set MaListe = New Liste ' instanciation de la classe Liste
  MaListe.Ajout "Dupont", "Dupont@hotmail.com"       ' ajout élément à l'objet a
  MaListe.Ajout "Martin", "Martin@hotmail.com"
  MaListe.Ajout "Durand", "Durand@hotmail.com"
  MaListe.Ajout "Balu", "Balu@hotmail.com"
  cle = "Durand"
  MsgBox "Email de " & cle & ": " & MaListe.item(cle)    ' affiche email de Durand
  MaListe.Tri                                                              ' tri objet Maliste
  Set plg = Range("a2").Resize(MaListe.count)
  Range("a2").Resize(MaListe.count) = MaListe.ListeCles
  Range("b2").Resize(MaListe.count) = MaListe.ListeItems
  MaListe.Sup "Dupont" ' suppression de Dupont
  MaListe.Ajout "Zoe", "Zoe@hotmail.com"
  Range("d2").Resize(MaListe.count) = MaListe.ListeCles
  Range("e2").Resize(MaListe.count) = MaListe.ListeItems
  indice = 2
  MsgBox "Clé " & indice & ":" & MaListe.cle(indice)
  MsgBox "Item " & indice & ":" & MaListe.ItemInd(indice)
  i = 2
  For Each c In MaListe.ListeCles
     Cells(i, "g") = c
     i = i + 1
  Next c
End Sub

Module de classe Liste

Option Compare Text
Private table()
Private xn

Private Sub class_initialize()
  xn = 0
End Sub

Sub Ajout(cle, item)
  xn = xn + 1
  ReDim Preserve table(1 To 2, 1 To xn)
  table(1, xn) = cle
  table(2, xn) = item
End Sub

Sub Sup(cle)
  p = 0
  For i = 1 To xn
    If table(1, i) = cle Then
       p = i
    End If
  Next i
  If p > 0 Then
    For i = p To xn - 1
     table(1, i) = table(1, i + 1)
     table(2, i) = table(2, i + 1)
   Next i
   xn = xn - 1
   ReDim Preserve table(1 To 2, 1 To xn)
  End If
End Sub

Property Get count()
  count = xn
End Property

Property Get Existe(cle)
   témoin = False
   For i = 1 To xn
     If table(1, i) = cle Then témoin = True
   Next i
   Existe = témoin
End Property

Property Get item(cle)
  temp = False
  i = 1
  témoin = False
  Do While i < xn And Not témoin
    If table(1, i) = cle Then
      temp = table(2, i)
      témoin = True
    End If
    i = i + 1
  Loop
  item = temp
End Property

Property Get cle(indice)
  If indice <= xn Then cle = table(1, indice) Else cle = ""
End Property

Property Get ItemInd(indice)
  If indice <= xn Then ItemInd = table(2, indice) Else ItemInd = ""
End Property

Property Get ListeCles()
  Dim temp()
  ReDim temp(1 To xn)
  For i = 1 To xn
    temp(i) = table(1, i)
  Next i
  ListeCles = Application.Transpose(temp)
End Property

Property Get ListeItems()
  Dim temp()
  ReDim temp(1 To xn)
  For i = 1 To xn
    temp(i) = table(2, i)
  Next i
  ListeItems = Application.Transpose(temp)
End Property

Public Sub Tri()
  Call Quick(table, 1, xn)
End Sub

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

Classe Base de données

La classe BD gère des enregistrements.
Elle permet d'ajouter, supprimer et trier des enregistrements.
C'est l'équivalent de SortedList avec plusieurs champs.
Construite avec l'objet Dictionary, elle permet d'accéder directement (rapidement) à un engistrement par une clé. Elle peut remplacer avantageusement des tableaux de taille importante. Les ajouts et suppressions sont plus faciles à gérer que dans un tableau classique.

ClasseBD Dictionary
ClasseBD Collection   

Méthodes et propriétés de la classe BD

Sub GestionBD()
  Set mabd = New BD
  a = [A2:C5]
  nchamp = UBound(a, 2) - LBound(a, 2) + 1
  Dim t(): ReDim t(1 To nchamp)
  For i = LBound(a) To UBound(a)     ' on alimente la BD
    For k = 1 To nchamp: t(k) = a(i, k): Next k
    mabd.Ajout t()
  Next i
  Range("a2").Resize(mabd.count, 3) = mabd.ListeBD    ' liste de la BD
  Range("a10").Resize(mabd.count, 3) = mabd.Tri     ' liste triée par noms
End Sub

Sub TriMult()
  Set mabd = New BD
  mabd.AjoutChamp ([A2:C5])
  Range("a17").Resize(mabd.count, mabd.NbChamp) = mabd.TriColMult(3, 2)
  Range("e17").Resize(mabd.count, mabd.NbChamp) = mabd.TriCol(2, "D")
  Range("a17").Resize(mabd.count, mabd.NbChamp) = mabd.TriCol(3, "A")
  Range("a17").Resize(mabd.count, mabd.NbChamp) = mabd.TriColMult(3, 1)
End Sub

Sub Stats()
  Set mabd = New BD
  mabd.AjoutChamp ([A2:C5])
  a = mabd.Stat2DCompte(2, 3)
  [A40].Resize(UBound(a), UBound(a, 2)) = a
End Sub

Sub Selection()
  Set mabd = New BD
  mabd.AjoutChamp ([A2:C5])
  a = mabd.GetEnregsColCle(3, "paris")
  [A44].Resize(UBound(a), UBound(a, 2)) = a
End Sub

Module de classe BD

Option Compare Text
Private Dict, nchamp

Private Sub class_initialize()
  Set Dict = CreateObject("Scripting.Dictionary")
  Dict.CompareMode = vbTextCompare
End Sub

Property Let NbChamp(NewChamp)
  If nchamp = 0 Then nchamp = NewChamp
End Property

Property Get NbChamp()
  NbChamp = nchamp
End Property

Sub Ajout(Enreg())
  Dict(Enreg(LBound(Enreg))) = Enreg()
  NbChamp = UBound(Enreg) - LBound(Enreg) + 1
End Sub

Sub AjoutChamp(Champ As Range)
  a = Champ
  Dim t(): ReDim t(LBound(a, 2) To UBound(a, 2))
  NbChamp = UBound(a, 2) - LBound(a, 2) + 1
  For i = LBound(a) To UBound(a) ' on alimente la BD
    For col = LBound(a, 2) To UBound(a, 2)
       t(col) = a(i, col)
    Next col
    Ajout t()
  Next i
End Sub

Property Get count()
  count = Dict.count
End Property

Property Get listeCles()
   listeCles = Application.Transpose(Dict.keys)
End Property

Property Get Existe(cle)
   Existe = Dict.Exists(cle)
End Property

Property Let Sup(cle)
  Dict.Remove (cle)
End Property

Property Get ListeEnreg(cle)
   temp = Dict(cle)
   ListeEnreg = temp
End Property

Function item(cle, col)
   temp = Dict(cle)
   item = temp(col)
End Function

Property Get ListeBD()
  Dim tbl()
  ReDim tbl(1 To Dict.count, 1 To nchamp)
  lig = 1
  For Each k In Dict.keys
    temp = Dict(k): decal = IIf(LBound(temp) = 0, 1, 0)
    For col = LBound(temp) To UBound(temp): tbl(lig, col + decal) = temp(col): Next col
   lig = lig + 1
  Next k
  ListeBD = tbl
End Property

Function Tri()
  temp = Dict.keys
  Call Quick(temp, LBound(temp), UBound(temp))
  Dim tbl()
  ReDim tbl(LBound(temp) To Dict.count - 1, 1 To nchamp)
  For lig = LBound(temp) To UBound(temp)
    tmp = Dict(temp(lig)): decal = IIf(LBound(tmp) = 0, 1, 0)
    For col = LBound(tmp) To UBound(tmp): tbl(lig, col + decal) = tmp(col): Next col
  Next lig
  Tri = tbl
End Function

Private Sub Quick(a, 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 Quick(a, g, droi)
  If gauc < d Then Call Quick(a, gauc, d)
End Sub

Private Sub class_terminate()
   Set Dict = Nothing
End Sub

Function TriCol(Optional colTri, Optional ordre)
  If IsMissing(colTri) Then colTri = "A"
  If IsMissing(ordre) Then ordre = 1
  tbl = ListeBD
  Select Case UCase(ordre)
     Case "A": Call QuickA(tbl, LBound(tbl), UBound(tbl), colTri)
     Case "D": Call QuickD(tbl, LBound(tbl), UBound(tbl), colTri)
     Case Else: Call QuickA(tbl, LBound(tbl), UBound(tbl), colTri)
  End Select
  TriCol = tbl
End Function

Module de classe Tableau

Cette classe Tableau:

-Tri un tableau déjà existant en ordre croissant/décroissant suivant la colonne spécifiée.
-Effectue des tris multi-critères.
-Donne des statistiques sur les tableaux (compte et somme suivant un critère)
-Sélectionne des lignes d'un tableau en fonction d'un critère.

Classe Tableau

Sub Tris()
  Tablo = [a2:D6].Value
  Set monTab = New Tableau             ' instanciation de la classe Tableau
  monTab.TriTab Tablo, 1              ' Tri col 1 
  [a2:D6] = Tablo
  monTab.TriTab Tablo, 2, "D"       ' Tri col 2 décroissant
  [F2:I6] = Tablo
  monTab.TriTabMult Tablo, 4, 1    ' Tri multi crit col 4, col 1
  [k2:N6] = Tablo
End Sub

Sub Stats()
  Tablo = [a3:D8].Value
  Set monTab = New Tableau
  b = monTab.Compte(Tablo, 3)       ' compte sur la colonne 3
  monTab.TriTab b, 2, "D"
  [k16].Resize(UBound(b), 2) = b
  b = monTab.Somme(Tablo, 3, 2)    ' somme sur colonne 2 en fonction du critère colonne 2
  monTab.TriTab b, 2, "D"
  [k23].Resize(UBound(b), 2) = b
  b = monTab.Stat2DCompte(Tablo, 1, 3) ' Stats 2D compte
  [k40].Resize(UBound(b), UBound(b, 2)) = b
  b = monTab.Stat2DSomme(Tablo, 1, 3, 2) ' Stats 2d somme
  [k50].Resize(UBound(b), UBound(b, 2)) = b
End Sub

Filtre un tableau avec 1 critère.

Sub SelectionLignesColCle()
  Tablo = [a3:D8].Value
  Set monTab = New Tableau
  a = monTab.GetLignesColCle(Tablo, 3, "paris") ' Sélection des lignes pour Paris
  [k30].Resize(UBound(a), UBound(a, 2)) = a
End Sub

Filtre un tableau avec 1 ou 2 critères. On choisi les colonnes résultat.

Sub FiltreArray()
  Dim montab As tableau
  Set montab = New tableau
  tablo = [a3:D8].Value
  b = montab.FiltreArray(tablo, 3, "Paris", Array(1, 2, 4))
  [k75].Resize(UBound(b) - LBound(b) + 1, UBound(b, 2)).Value2 = b
End Sub

Module de classe Tableau

Option Compare Text

Sub TriTab(Tbl, Optional colTri, Optional ordre)
  If IsMissing(colTri) Then colTri = 1
  If IsMissing(ordre) Then ordre = 1
  Dim clé(): ReDim clé(LBound(Tbl) To UBound(Tbl))
  Dim idx() As Long: ReDim idx(LBound(Tbl) To UBound(Tbl))
  Dim b(): ReDim b(LBound(Tbl) To UBound(Tbl), LBound(Tbl, 2) To UBound(Tbl, 2))
  For i = LBound(Tbl) To UBound(Tbl)
     clé(i) = Tbl(i, colTri)
     idx(i) = i
  Next i
  Select Case UCase(ordre)
    Case "A": Call QuickI(clé(), idx(), LBound(clé), UBound(clé))
    Case "D": Call QuickIDesc(clé(), idx(), LBound(clé), UBound(clé))
    Case Else: Call QuickI(clé(), idx(), LBound(clé), UBound(clé))
  End Select
  For lig = LBound(clé) To UBound(clé)
     For col = LBound(Tbl, 2) To UBound(Tbl, 2): b(lig, col) = Tbl(idx(lig), col): Next col
  Next lig
  For lig = LBound(clé) To UBound(clé)
      For col = LBound(Tbl, 2) To UBound(Tbl, 2): Tbl(lig, col) = b(lig, col): Next col
  Next lig
End Sub

Sub TriTabMult(tbl, Optional ColTri1, Optional Coltri2)
  If IsMissing(ColTri1) Then ColTri1 = 1
  If IsMissing(Coltri2) Then Coltri2 = 2
  Dim clé() As String: ReDim clé(LBound(tbl) To UBound(tbl))
  Dim idx() As Long: ReDim idx(LBound(tbl) To UBound(tbl))
  Dim b(): ReDim b(LBound(tbl) To UBound(tbl), LBound(tbl, 2) To UBound(tbl, 2))
  If IsNumeric(tbl(1, ColTri1)) Or IsDate(tbl(1, ColTri1)) Then tri1 = "num"
  If IsNumeric(tbl(1, Coltri2)) Or IsDate(tbl(1, Coltri2)) Then tri2 = "num"
  For i = LBound(tbl) To UBound(tbl)
     If tri1 = "num" Then col1 = Format(tbl(i, ColTri1), "0000000") Else col1 = tbl(i, ColTri1)
     If tri2 = "num" Then col2 = Format(tbl(i, Coltri2), "0000000") Else col2 = tbl(i, Coltri2)
     clé(i) = col1 & "_" & col2
   idx(i) = i
  Next i
  Call QuickI(clé(), idx(), LBound(clé), UBound(clé))
  For lig = LBound(clé) To UBound(clé)
     For col = LBound(tbl, 2) To UBound(tbl, 2): b(lig, col) = tbl(idx(lig), col): Next col
  Next lig
  For lig = LBound(clé) To UBound(clé)
     For col = LBound(tbl, 2) To UBound(tbl, 2): tbl(lig, col) = b(lig, col): Next col
  Next lig
End Sub

Sub QuickI(clé(), index() As Long, gauc, droi) ' Quick sort
  ref = clé((gauc + droi) \ 2)
  g = gauc: d = droi
  Do
    Do While clé(g) < ref: g = g + 1: Loop
    Do While ref < clé(d): d = d - 1: Loop
      If g <= d Then
         temp = clé(g): clé(g) = clé(d): clé(d) = temp
         temp = index(g): index(g) = index(d): index(d) = temp
         g = g + 1: d = d - 1
      End If
    Loop While g <= d
    If g < droi Then Call QuickI(clé, index, g, droi)
    If gauc < d Then Call QuickI(clé, index, gauc, d)
End Sub

Simulation de l'objet Dictionary pour Excel Mac

Pour simuler l'objet Dictionary sur Excel Mac, on crée un module de classe DictionnaireMac.

ClasseDictionnaireMacCollection
ClasseDictionnaireMacTableau

Méthodes et propriétés

Exemple 1: Sur cet exemple, nous obtenons une liste sans doublons.

Sur l'exemple, nous créons un dictionnaire avec les noms comme clés et les villes comme items.
Les doublons de Nom1 seront éliminés.

Noms Villes
Nom1 Ville1
Nom2 Ville2
Nom3 Ville3
Nom4 Ville4
Nom1 Ville1
Nom1 Ville1
Nom7 Ville7

Code

Sub ListeSansDoublonsCollection()
  Set d1 = New DictionnaireMac
  Set plage1 = Range("A2", [a65000].End(xlUp))
  For Each c In plage1
      If c <> "" Then d1.ajout c.Value, c.Offset(, 1).Value
  Next c
  '-------- transfert dans le tableur
  Range("d2").Resize(d1.count) = d1.listeCles
  Range("e2").Resize(d1.count) = d1.listeItems
  [P2].Resize(d1.count, 2) = d1.Tri
End Sub

Module de classe DictionnaireMac

L'option Key de la classe Collection permet d'interdire les doublons à la création et d'accéder à un item par une clé mais elle ne permet pas d'accéder à l'ensemble des clés. Pour accéder à l'ensemble des clés, nous utilisons une deuxième collection (CollecCle).
L'objet Collec stocke les items et l'objet CollecCle les clés

Cette classe simule la classe Dictionary en lui ajoutant un Tri.
Elle peut remplacer SortedList. Elle permet par exemple:
- d'obtenir des listes triées sans doublon,
- d'effectuer des tris multi-critères de tableaux à 2 dimensions,...

Option Compare Text
Private xn
Private Collec As New Collection
Private CollecCle As New Collection

Sub ajout(cle, item)
  On Error Resume Next
  Collec.Add item:=item, Key:=cle
  CollecCle.Add item:=cle, Key:=cle
  If Err = 0 Then xn = xn + 1
End Sub

Property Get count()
  count = xn
End Property

Property Get listeItems()
  Dim temp()
  ReDim temp(1 To xn)
  For i = 1 To xn
    temp(i) = Collec(i)
  Next i
  listeItems = Application.Transpose(temp)
End Property

Property Get listeCles()
  Dim temp()
  ReDim temp(1 To xn)
  For i = 1 To xn
    temp(i) = CollecCle(i)
  Next i
  listeCles = Application.Transpose(temp)
End Property

Property Get item(cle)
  item = Collec(cle)
End Property

Property Get Existe(cle)
  On Error Resume Next
  retour = Collec(cle)
  Existe = (Err = 0)
End Property

Property Get cle(indice)
  If indice <= xn Then cle = CollecCle(indice) Else cle = ""
End Property

Property Get ItemInd(indice)
  If indice <= xn Then ItemInd = Collec(indice) Else ItemInd = ""
End Property

Sub Sup(cle)
  p = 0
  For i = 1 To xn
     If CollecCle(i) = cle Then p = i
  Next i
  If p > 0 Then
    CollecCle.Remove p
    Collec.Remove p
    xn = xn - 1
  End If
End Sub

Function Tri()
  Dim temp()
  ReDim temp(1 To xn, 1 To 2)
  For i = 1 To xn
    temp(i, 1) = CollecCle(i)
    temp(i, 2) = Collec(i)
  Next i
  Call Quick(temp, LBound(temp), UBound(temp))
  Tri = temp
End Function

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

Classe Dictionnaire

Cette classe encapsule la classe Dictionary en lui ajoutant un Tri.
Elle peut remplacer SortedList. Elle permet par exemple:
- d'obtenir des listes triées sans doublon ( 0,36s pour 10.000 items)
- d'effectuer des tris multi-critères de tableaux à 2 dimensions,...

Classe Dictionnaire Tri
Classe DictionarySorted David84

Sub ListeSansDoublonsDicoTrié()
  Set d1 = New Dictionnaire
  a = Range("A2:B" & [A65000].End(xlUp).Row)
  For i = 1 To UBound(a)
    d1.ajout a(i, 1), a(i, 2)
  Next i
  '--- résultat dans le tableur
  Range("d2").Resize(d1.Count, 2) = d1.Tri
  '-- résultat dans un tableau
  a = d1.Tri
End Sub

Module de classe Dictionnaire

Private Dict
Option Compare Text

Private Sub class_initialize()
  Set Dict = CreateObject("Scripting.Dictionary")
  Dict.CompareMode = vbTextCompare
End Sub

Sub ajout(cle, item)
  If Not Dict.Exists(cle) Then Dict(cle) = item
End Sub

Property Get Count()
  Count = Dict.Count
End Property

Property Get listeItems()
  listeItems = Application.Transpose(Dict.Items)
End Property

Property Get listeCles()
  listeCles = Application.Transpose(Dict.keys)
End Property

Property Get item(cle)
  item = Dict(cle)
End Property

Property Get Existe(cle)
  Existe = Dict.Exists(cle)
End Property

Sub Sup(cle)
  Dict.Remove cle
End Sub

Function Tri()
  Dim temp()
  ReDim temp(1 To Dict.Count, 1 To 2)
  i = 1
  For Each c In Dict.keys
    temp(i, 1) = c
    temp(i, 2) = Dict(c)
    i = i + 1
  Next c
  Call Quick(temp, LBound(temp), UBound(temp))
  Tri = temp
End Function

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

Private Sub class_terminate()
  Set Dict = Nothing
End Sub

Simulation de ArrayList et SortedList

Dans le fichier ci dessous, on trouvera un module de classe Aliste(tableau 1 dimension trié) qui remplace ArrayList (+rapide)

Classe AListe

Dans le fichier ci dessous, on trouvera un module de classe Sliste (tableau 2D trié) qui remplace SortedList (Il est 2 fois +rapide :0,28s pour 10.000 lignes).
En outre, il accepte les doublons. Si on veut supprimer ces derniers, on peut utiliser Dictionary qui est très rapide.
Cette classe peut être utilisée pour trier des tableaux multi-dimensionnel.

Classe SListe
Classe SortedListe Collection David 84

Module de classe Arborescence/Organigramme

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, ",")
   clé = a(0): élem = a(1)
   n = n + 1
   Tbl(n, 1) = a(0): Tbl(n, 2) = élem: 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)
  créeShape tmp, 1, Attribut(tmp)
  Set débutOrg = fbd.Range("c4")
  colonne = 0
  inth = 50
  intv = 40
  PosShape tmp, 1
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
  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)
  End With
  For i = 1 To n
    If Tbl(i, 2) = parent Then créeShape Tbl(i, 1), niv + 1, Tbl(i, 3)
  Next i
End Sub

Sub PosShape(parent, niv) ' procédure récursive
  colonne = colonne + 1
  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, 813.75, 258.75, 885.75, 330.75).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 PosShape Tbl(i, 1), niv + 1
  Next i
End Sub