Objet dictionary (Dictionnaire Excel)

Accueil


Accés aux éléments d'un dictionnaire
Transfert d'un dictionnaire dans le tableur
Utilisation de Microsoft Scripting Runtime
Dictionnaire de dictionnaire
Liste triée d'un dictionnaire
Tri d'un dictionnaire
Dictionnaire comme index tableau 2D
Tableau comme élément d'un dictionnaire(dictionnaire muti-colonnes)
Dictionnaire multi-colonnes pour remplacer un Array 2D
Extraction d'une partie d'un dictionnaire
Liste sans doublons
Liste des doublons
Liste des non doublons(valeurs uniques)
Liste sans doublons pour CombBox/ListBox
Liste sans doublons triée pour ComboBox/ListBox
Liste sans doublons 2 colonnes pour Combobox
Compter les éléments
Maj Stock
Consolidation de plusieurs tableaux
Sous total de tableau 2D avec indexation dictionnaire
Regroupement de lignes avec sous-total avec indexation tableau par dictionnaire
Fusion de lignes doublons
Regroupement dans une cellule
Statistiques 2D
Fonction de consolidation multi-zones
Transforme BD en tableau
Transforme Tableau en BD
Comparaison dictionary/collection
Comparaison Dictionary/Tableau/Find
Simulation Dictionary pour Excel Mac
Repérage de doublons
Fonction liste sans doublons triée
Rechv() perso plus rapide que Recherchev() & Sommeprod()
Alimenter un comboBox avec une liste triée sans doublons
Choix successifs(listes différences)
Fonction de comptage sans doublons avec critère
Suppression doublons dans une BD
Liste des doublons
Eléments communs à 2 listes
Liste Abréviations sans doublons
Liste des items sans doublons
Regroupement des items de chaque code
Listes inverses
Comparaison de 2 classeurs
Fonction liste sans doublons triée multi-zones
Suppression de doublons multi-feuilles
Maj d'une liste existante
Indexation d'un tableau 2D par un dictionnaire
Meilleure note
Recherche d'une valeur proche
Indexation d'un tableau 2D avec Dictionary pour augmenter la vitesse
Remplacer par multiple
Recherche rapide de mots dans une phrase
Indexation d'une BD pour recherche rapide de mots
Fonction frequence Texte
Nombre d'occurences des doublons
Communs à 3 listes
Extraction d'un Array
Fonction perso NBSIMAT plus rapide que NB.SI()
Nombre de valeurs uniques avec 1 ou 2 critères

 

-L'objet Dictionary associe des valeurs à des clefs. L'objet Dictionary permet notamment de générer des listes sans doublons. Cet objet, simple à programmer, est très performant. Ne pas utiliser l'objet Collection qui est lent.
-Dictionary peut être vu comme un tableau à une dimension. On accède aux éléments par une clé et non pas un indice.
-Pour les ajouts/suppressions, l'objet Dictionary est + facile à utiliser qu'un tableau (Redim + indice à gérer).

L'accès aux clés particulièrement rapide doit s'expliquer par l'utilisation de hash-code qui fait correspondre à une clé alphabétique une adresse de rangement numérique - par un algorithme - et donc de la retrouver directement au lieu de balayer une table séquentiellement.

 

Add clé,élément

Ajoute une clé et la valeur associée

Exists(clé)

Teste l'existence d'une clé

Tbl=Items

Donne dans un tableau les éléments

Tbl=Keys

Donne dans un tableau les clés

Remove (clé)

Suprime la clé

Removeall

Supprime tous les éléments

Count

Donne le nombre d'éléments

Item(clé) =valeur

Modifie la valeur de la clé

Item(clé)

Donne la valeur associée à la clé

CompareMode=vbTextCompare

Ignore la casse

Accès aux éléments d'un dictionnaire

DictionaryAccés

Sub ListeDictionnaire()
  Set d = CreateObject("Scripting.Dictionary")
  d.Item("Dupont") = 35      ' ou If Not d.Exists("aa") Then d.Add "Dupont", 35
  d.Item("Durand") = 40
  d.Item("Martin") = 27       ' ou d("Durand")=40
  d.Item("Espinasse") = 32
  '---- élément pour une clé
  clé = "Durand"
  MsgBox clé & ":" & d.Item(clé)   ' ou MsgBox d(clé)
  '--- toutes les clés et valeurs associées
  For Each c In d.keys
     MsgBox c & ":" & d.Item(c) ' ou MsgBox c & ":" & d(c)
  Next c
  '---- 3eme élément
  a = d.keys     ' dans un tableau a(0 To d.Count-1)
  b = d.items    ' dans un tableau b(0 To d.Count-1)
  MsgBox a(2) & ":" & b(2)
  '--- Rang d'une clé
  clé = "Durand"
  p = Application.Match(clé, d.keys, 0)
  MsgBox "position de " & clé & ":" & p
  '--- Stats
  MsgBox "Total:" & Application.Sum(d.items)
  MsgBox "Mini:" & Application.Min(d.items)
  MsgBox "Moyenne:" & Application.Average(d.items)
End Sub

Pour que majuscules/minuscules soient confondues.

d.CompareMode = vbTextCompare

Transfert d'un dictionnaire dans le tableur

TransfertTableurTableaux

Sub TransfertDictionnaireTableur()
  Set d = CreateObject("Scripting.Dictionary")
  d.Item("Dupont") = 35
  d.Item("Durand") = 27
  d.Item("Martin") = 40
  d.Item("Espinasse") = 32
  '-- horizontal
  [E2].Resize(, d.Count) = d.keys
  [E3].Resize(, d.Count) = d.items
  '-- vertical 
  [A2].Resize(d.Count) = Application.Transpose(d.keys)
  [B2].Resize(d.Count) = Application.Transpose(d.items)
End Sub

Transfert d'un dictionnaire dans des tableaux

Le transfert des clés d'un dictionnaire dans une table a() se fait avec a=d.keys (Lbound(a) --> 0)

Sub TransfertDictionnaireTableaux()
  Set d = CreateObject("Scripting.Dictionary")
  d.Item("Dupont") = 35
  d.Item("Durand") = 27
  d.Item("Martin") = 40
  d.Item("Espinasse") = 32
  '--- Tableaux
  a = d.keys   ' transfert dans tableau a(0 To n-1)
  b = d.items  ' transfert dans tableau b(0 To n-1)
  [A2].Resize(d.Count) = Application.Transpose(a) ' Transfert des tableaux dans le tableur
  [B2].Resize(d.Count) = Application.Transpose(b)
End Sub

Utilisation de Microsoft scripting runtime dans Outils/Référence

Si Microsoft Scripting Runtime est coché dans Outils/Référence, on peut déclarer un dictionnaire par

Dim d As New Dictionary

Dans ce cas, on peut accéder aux clés et aux items par un indice.
L'intérêt des dictionnaires est l'accès par clé. Utiliser l'accès par un indice n'apporte rien par rapport aux Arrays().

'Microsoft scripting runtime doit être coché dans Outils/Référence
Dim d As New Dictionary
d.Item("Dupont") = 35 ' ou If Not d.Exists("aa") Then d.Add "Dupont", 35
d.Item("Durand") = 40
d.Item("Martin") = 27 ' ou d("Durand")=40
d.Item("Espinasse") = 32
MsgBox d.Keys(2)
MsgBox d.Items(2)

Dictionnaire de dictionnaire

Sub DictionnaireDictionnaire()
  'Microsoft scripting runtime est coché
  Dim d1 As New Scripting.Dictionary
  Dim d2 As New Scripting.Dictionary
  Dim dd As New Scripting.Dictionary ' dictionnaire de dictionnaire
  Dim Ptr As New Scripting.Dictionary

  d1.Add "aa", 11: d1.Add "bb", 22
  d2.Add "cc", 33: d2.Add "dd", 44

  Set dd("dico1") = d1: Set dd("dico2") = d2

  Set Ptr = dd("dico1")
  MsgBox Ptr.Items(1): MsgBox Ptr("bb") ' affiche 22
  Set Ptr = dd("dico2")
  MsgBox Ptr.Items(1): MsgBox Ptr("dd") ' affiche 44
End Sub

Problème d'inversion jour/mois pour les dates

Pour éviter l'inversion des jours/mois dans les dates, utiliser Value2

Set d = CreateObject("scripting.dictionary")
For Each c In [A2:a13]
  d(c.Value) = c.Offset(, 1).Value2
Next c
[d2].Resize(d.Count) = Application.Transpose(d.keys)
[E2].Resize(d.Count) = Application.Transpose(d.items)

Ou à la restitution, utiliser FormulaLocal

[E2].Resize(d.Count).FormulaLocal = Application.Transpose(d.items)

Accès à un item de dictionnaire par un indice

Les dictionnaires ont étés conçus pour un accès à un item par une clé.
L'accès par un indice se fait par la création explicite ou implicite d'un Array()

AccesIndice

Sub AccesItemParUnIndice()
  Set d = CreateObject("Scripting.Dictionary")
  d.Item("Dupont") = 35
  d.Item("Durand") = 27
  d.Item("Martin") = 40
  d.Item("Espinasse") = 32
  '---
  Tbl1 = d.keys 'tableau Tbl1() crée une seule fois
  Tbl2 = d.items 'tableau Tbl2() crée une seule fois
  For n = 0 To d.Count - 1
     MsgBox Tbl1(n) & ", " & Tbl2(n)
  Next n
  '--les tableaux Tbl1() et Tbl2() sont recrées implicitement à chaque Msgbox donc moins     performant
  For n = 0 To d.Count - 1
    MsgBox d.keys()(n) & " - " & d.items()(n)
  Next n
End Sub

Transfert d'un dictionnaire dans un autre dictionnaire

Sub TransfertDictionnaireDictionnaire()
  Set d1 = CreateObject("Scripting.Dictionary")
  d1.Item("Dupont") = 35
  d1.Item("Durand") = 27
  d1.Item("Martin") = 40
  d1.Item("Espinasse") = 32
  Set d2 = d1
  '-- horizontal
  [E2].Resize(, d2.Count) = d2.keys
  [E3].Resize(, d2.Count) = d2.items
End Sub

Liste triée d'un dictionnaire

Pour obtenir une liste triée d'un dictionnaire, on transfère le dictionnaire dans un tableau temp(n,2) que l'on tri.

Liste triée d'un dictionnaire

Keys

Items

Dupont

35

Durand

40

Espinasse

32

Martin

27

Sub ListeTriéeDictionnaire()
  Set d = CreateObject("Scripting.Dictionary")
  d.Item("Dupont") = 35
  d.Item("Martin") = 27
  d.Item("Durand") = 40
  d.Item("Espinasse") = 32
  Dim temp(): ReDim temp(1 To d.Count, 1 To 2)
  i = 1
  For Each c In d.keys
     temp(i, 1) = c
     temp(i, 2) = d(c)
     i = i + 1
   Next c
   Call Quick(temp, LBound(temp), UBound(temp))
  [A2].Resize(d.Count, 2).Value2 = temp
End Sub

Tri d'un dictionnaire

Pour trier un dictionnaire dans l'ordre des clés, il faut le transférer dans un Array, trier l'Array puis recréer le dictionnaire avec l'Array trié.

Tri Dico Keys sans items
Tri Dico Keys/Items Procédure
Tri Dico Keys/Items Fonction

Option Compare Text
Sub TriDico()
  Set f = Sheets("BD")
  Set d1 = CreateObject("Scripting.Dictionary")
  d1.CompareMode = vbTextCompare

  a = f.Range("A2:A" & f.[A65000].End(xlUp).Row) ' tableau a(n,1) pour rapidité
  For i = LBound(a) To UBound(a)
    If a(i, 1) <> "" Then d1(a(i, 1)) = ""
  Next i
  DicoTri d1
  f.[C2].Resize(d1.Count) = Application.Transpose(d1.keys)
End Sub

Sub DicoTri(dico)
  Tbl = dico.keys                           ' Transfert Dictionnaire dans Array
  Tri Tbl, LBound(Tbl), UBound(Tbl) ' Tri Array
  dico.RemoveAll                           ' Création du dictionnaire
  For i = LBound(Tbl) To UBound(Tbl)
    dico(Tbl(i)) = ""
  Next i
End Sub

Extraction d'une partie de dictionnaire

Dans l'exemple ci dessous, nous obtenons 30 élements d'un dictionnaire à partir du 30e

Sub ExtraitDico()
  Set d = CreateObject("scripting.dictionary")
  For i = 1 To 100: d(i) = "": Next
  '--- Extrait dico
  Position = 30
  taille = 20
  [A1].Resize(taille) = Application.Index(d.keys, Evaluate("Row(" & Position & ":" & Position + taille & ")"))
  'b= Application.Index(d.keys, Evaluate("Row(" & Position & ":" & Position + taille & ")"))
End Sub

Ci dessous, nous découpons un dictionnaire par tranches de 3

Sub decoupeDico()
  Set d = CreateObject("scripting.dictionary")
  For i = 1 To 12: d(i) = "": Next
  '--- découpe
  pas = 3
  For k = 0 To d.Count / pas - 1
    decal = k * pas + 1
   [C1].Resize(pas).Offset(k * (pas + 1)) = Application.Index(d.keys, Evaluate("Row(" & decal & ":" & decal + pas & ")"))
  Next k
End Sub

Liste sans doublons pour combobox ou listbox

FormLSD
FormLSDCollectionMAC

Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Set MonDico = CreateObject("Scripting.Dictionary")
  a = f.Range("A2:A" & f.[A65000].End(xlUp).Row)     ' tableau a(n,1) pour rapidité
  For i = LBound(a) To UBound(a)
     If a(i, 1) <> "" Then MonDico(a(i, 1)) = ""
  Next i
  Me.ComboBox1.List = MonDico.keys
End Sub

Liste sans doublons triée pour ComboBox ou ListBox

Form ComboBox trié

Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Set mondico = CreateObject("Scripting.Dictionary")
  a = f.Range("A2:A" & f.[A65000].End(xlUp).Row) ' tableau a(n,1) pour rapidité
  For i = LBound(a) To UBound(a)
    If a(i, 1) <> "" Then mondico(a(i, 1)) = ""
  Next i
  '--avec tri
  temp = mondico.keys
  Call Tri(temp, LBound(temp), UBound(temp))
  Me.ComboBox1.List = temp

Sur MAC, Dictionary n'existe pas. Pour obtenir une liste sans doublons, utiliser Collection:

FormLSDCollectionMAC
FormLSDTriéMAC

Option Compare Text
Dim f
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Dim a()
  a = Application.Transpose(f.Range("A2:A" & f.[A65000].End(xlUp).Row).Value)
  Me.ComboBox1.List = SansDoublonsMAC(a())
End Sub

Function SansDoublonsMAC(a())
  Dim Maliste As New Collection
  On Error Resume Next
  For i = LBound(a) To UBound(a)
     Maliste.Add Item:=a(i), key:=a(i)
  Next i
  On Error GoTo 0
  Dim b(): ReDim b(1 To Maliste.Count)
  For i = 1 To Maliste.Count
    b(i) = Maliste(i)
  Next i
  SansDoublonsMAC = Application.Transpose(b)
End Function

Elimine les doublons à l'intérieur d'une cellule

Sans Doublons Cellule
Sans Doublons Cellule MAC

Function SansDoublon(c, sep)
  a = Split(Application.Trim(c), sep)
  Set mondico = CreateObject("Scripting.Dictionary")
  For i = 0 To UBound(a): mondico.Item(a(i)) = 1: Next i
  SansDoublon = Join(mondico.keys, sep)
End Function

Listes sans doublons avec 2 colonnes (Nom+prénom)

Form Cascade SansDoublons 2 colonnes Dict
Form Sans Doublons plusieurs colonnes
FormCascadeSansDoublons2colonnesListBoxDict
Form Cascade Sans Doublons 2 colonnes Trié
Form Cascade Sans Doublons 2 colonnes Disjointes Trié
FormCascadeSansDoublons2colonnesMAC

Dim f, a()
Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  a = f.Range("A2:D" & f.[B65000].End(xlUp).Row).Value
  Set d = CreateObject("Scripting.Dictionary")
  j = 0
  For i = LBound(a) To UBound(a)
    tmp = a(i, 1) & a(i, 2)
    If Not d.exists(tmp) Then
      d(tmp) = ""
      Me.ComboBox1.AddItem a(i, 1)
      Me.ComboBox1.List(j, 1) = a(i, 2)
      j = j + 1
    End If
  Next i
End Sub

ou

Dim f, a()
Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  a = f.Range("A2:D" & f.[B65000].End(xlUp).Row).Value
  Me.ComboBox1.List = f.Range("A2:D" & f.[B65000].End(xlUp).Row).Value
  Set d = CreateObject("Scripting.Dictionary")
  j = 0
  Do While j < Me.ComboBox1.ListCount
    tmp = ComboBox1.List(j, 0) & ListBox1.List(j, 1)
    If Not d.exists(tmp) Then
     d(tmp) = ""
     j = j + 1
   Else
      Me.ComboBox1.RemoveItem j
   End If
Loop
End Sub

Utilisation de Sum,Average,Match,Max,Min avec le dictionnaire

ttal = Application.Sum(d.items) donne la somme des items
Moy = Application.Average(d.items) donne la moyenne
p=Application.Match("toto",d.keys,0) donne la postion de toto dans le dictionnaire

Dictionnaire comme index de tableau (Array)

Pour retrouver plus rapidement la ligne d'un tableau Tbl(,) corrrespondant à un nom, on peut indexer le tableau Tbl(,) avec un dictionnaire.
Remarque :Le système d'indexation d'un tableau 2D par un dictionnaire est plus rapide qu'un dictionnaire multi-colonnes.

IndexDico

Sub essaiIndex()
  Set d = CreateObject("Scripting.Dictionary")
  Tbl = [A2:D6] ' BD
  '----- création du dictionnaire index
  For i = 1 To UBound(Tbl)
     d(Tbl(i, 1)) = i
  Next i
  '------ recherche de Durand
  clé = "Durand"
  ligne = d(clé)
  [G2:J2] = Application.Index(Tbl, ligne)
End Sub

Dictionnaire multi-colonnes (tableau comme élément de dictionnaire)

Les items d'un dictionnaire peuvent être des tableaux.

DicoTab

Clé

 

Ville

Salaire

Age

Martin

->

Lyon

5000

23

Dupont

->

Paris

5000

35

Durand

->

Paris

4000

22

 

 

 

 

 

Sub DictionnaireArray()
  Set d = CreateObject("Scripting.Dictionary")
  ville = "Paris"
  d.Item("Martin") = Array(ville, 5000, 24)
  d.Item("Toto") = Array("Lyon", 6000, 25)
  d.Item("Titi") = Array("Issy", 6000, 34)
  [A2].Resize(d.Count) = Application.Transpose(d.keys)
  MsgBox d.Item("Toto")(0)
  b = Application.Transpose(Application.Transpose(d.items)) ' dictionnaire dans array b(1 to n,1 to 3)
  [B2].Resize(UBound(b), UBound(b, 2)) = b
  [A1:D1] = Array("Nom", "Ville", "Salaire", "Age")
End Sub

Autres exemples

Sub EssaiDictionnaire()
  Set d = CreateObject("Scripting.Dictionary")
  ville = "Lyon"
  d.Item("Martin") = Array(ville, 5000, 23)
  MsgBox d.Item("Martin")(0)
  '--
  Dim a(1 To 3)
  a(1) = "Paris": a(2) = 5000: a(3) = 45 ' tableau a()
  d.Item("Dupont") = a
  MsgBox d.Item("Dupont")(1)
  b = d.Item("Dupont")
  MsgBox b(3)
  For Each c In d.Item("Dupont")
     MsgBox c
  Next c
  [N1].Resize(, 3) = d.Item("Dupont")   ' affiche la fiche de Dupont
End Sub

Sub Array2DdansDictionnaire()
  Set d = CreateObject("Scripting.Dictionary")
  '--- transfert Array dans dico
  a = [A2:D4]
  Ncol = UBound(a, 2)
  ReDim tmp(1 To Ncol)
  For i = LBound(a) To UBound(a)
    For k = 1 To Ncol: tmp(k) = a(i, k): Next
    d(a(i, 1)) = tmp ' ou d(a(i, 1)) = Application.Index(a, i)
  Next i
  'MsgBox d.Item("Toto")(2)
  '------------ récup dico dans Array 2D
  b = Application.Transpose(Application.Transpose(d.items)) ' dictionnaire dans array b(1 to n,1 to 4)
  [G2].Resize(UBound(b), UBound(b, 2)) = b
End Sub

Autre exemple

Sub Essai()
  Set d = CreateObject("Scripting.Dictionary")
  a = Evaluate("{1,2,3;4,5,6;7,8,9;10,11,12}")   ' 1 à 4 x 1 à 3
  d.Item("xx") = a
  Z = d("xx")(2, 1)                          ' a(2,1)
  MsgBox Z
  b = Application.Index(d("xx"), 2)   ' 2e ligne
  MsgBox b(2)
  c = Application.Index(d("xx"), , 3) ' 3e colonne
  MsgBox c(2, 1)
End Sub

On veut la première ligne de chaque équipe

Sans Doublons Multi-colonnes

Sub SansDoublons()
  Set d = CreateObject("Scripting.Dictionary")
  a = [A2:D9]
  For i = LBound(a) To UBound(a)
    If Not d.exists(a(i, 4)) Then
      d.Item(a(i, 4)) = Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4))
    End If
  Next i
  [g2].Resize(d.Count, UBound(a, 2)) = Application.Transpose(Application.Transpose(d.items))
End Sub

ou

Sub SansDoublons2()
  Set d = CreateObject("Scripting.Dictionary")
  a = [A2:D9]
  ReDim b(1 To UBound(a, 2))
  For i = LBound(a) To UBound(a)
    If Not d.exists(a(i, 4)) Then
      For k = 1 To UBound(a, 2): b(k) = a(i, k): Next
      d.Item(a(i, 4)) = b
    End If
  Next i
  [g2].Resize(d.Count, UBound(a, 2)) = Application.Transpose(Application.Transpose(d.items))
End Sub

Simulation Array Indicés

Simulation Array Indicés

Sous total tableau multicolonnes

Ici, nous effectuons un sous total d'un tableau multi-colonnes dans un dictionnaire multi-colonnes.

Sous total multi-colonnes
Fonction Suppression des doublons d'un Array
Suppression des doublons d'un Array (toutes colonnes)

Dim d1
Sub Stat()
  Set d1 = CreateObject("Scripting.Dictionary")
  Set f1 = Sheets("données")
  Ncol = f1.[a1].CurrentRegion.Columns.Count
  a = f1.[a1].CurrentRegion
  Totalise a
  Set f2 = Sheets("résultats")
  f1.[a1].Resize(, Ncol).Copy f2.[a1]
  f2.[a2].Resize(d1.Count, 1) = Application.Transpose(d1.keys)
  f2.[B2].Resize(d1.Count, Ncol - 1) = Application.Transpose(Application.Transpose(d1.items))
  f2.Activate
  '[a1].CurrentRegion.Sort Key1:=Range("a2"), Header:=xlYes
End Sub

Sub Totalise(a)
  ReDim Titem(1 To UBound(a, 2)) ' table des items d'une clé
  For ligne = 2 To UBound(a)
    crit = a(ligne, 1)
    If Not d1.exists(crit) Then For k = 1 To UBound(a, 2): Titem(k) = 0: Next k: d1(crit) = Titem
    For k = 1 To UBound(a, 2): Titem(k) = d1.Item(crit)(k): Next k
    For col = 2 To UBound(a, 2)
      If a(ligne, col) <> "" Then Titem(col - 1) = Titem(col - 1) + Val(a(ligne, col))
    Next col
    d1.Item(crit) = Titem
  Next ligne
End Sub

Tri d'un dictionnaire multi-colonnes

Liste triée d'un dictionnaire multi-colonnes

Sub ListeTriéeDictionnaireMultiCol()
  Set d = CreateObject("Scripting.Dictionary")
  d.Item("Dupont") = Array("Paris", 5000, #12/10/1980#)
  d.Item("Martin") = Array("Lyon", 4000, #12/10/1980#)
  d.Item("Durand") = Array("Issy", 6000, #12/10/1980#)
  d.Item("Espinasse") = Array("Montigny", 3000, #12/10/1990#)
  Dim temp(): ReDim temp(1 To d.Count, 1 To 2)
  i = 1
  For Each c In d.keys
    temp(i, 1) = c
    temp(i, 2) = d(c)
    i = i + 1
   Next c
   Call Quick(temp, LBound(temp), UBound(temp))
   For i = LBound(temp) To UBound(temp)
     Cells(i + 1, 1) = temp(i, 1)
     Cells(i + 1, 2) = temp(i, 2)(0)
     Cells(i + 1, 3) = temp(i, 2)(1)
   Next i
End Sub

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

ClasseBD Dictionary

Dictionnaire multi-colonnes

En remplaçant un Array 2D par un dictionnaire multi-colonnes:

-Les suppressions de lignes ou ajouts deviennent très simples
-Le dictionnaire multi-colonnes peut être transféré dans Array 2D classique b(,)

Encapsule Array
TransfertBD sans lignes vides dans ListBox
ListBox conditionnelle
TransfertBD sans lignes vides dans ListBox Trié
RegroupeSousTotal Plusieurs Colonnes Plusieurs champs 2
RegroupeSousTotal Plusieurs Colonnes Plusieurs Champs 3 Dico

Sub ArrayEncapsuléDico()
  Set d = CreateObject("Scripting.Dictionary")
  a = [A2:C6]
  For i = LBound(a) To UBound(a)
     d.Item(a(i, 1)) = Array(a(i, 1), a(i, 2), a(i, 3))
  Next i
  '--accès à la ville de Durand
  [k2] = d("Durand")(1)
  '---suppression d'une ligne
  d.Remove ("Espinasse")
  '----- affichage du tableau dans le tableur
  b = Application.Transpose(Application.Transpose(d.items)) ' dictionnaire dans array b(1 to n,1 to 3)
  [F2].Resize(UBound(b), UBound(b, 2)) = b
  'MsgBox b(1, 2) ' accès à un item de b(,)
End Sub

Liste sans doublons

ListeSansDoublons
Liste sans doublons Array MAC

0,26 sec pour 16.000 lignes

Sub ListeSansDoublons()
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range("a2", [a65000].End(xlUp))
    mondico(c.Value) = ""
  Next c
  [C2].Resize(mondico.Count, 1) = Application.Transpose(mondico.keys)
End Sub

Remarque
mondico(c.Value) = "" <=> mondico.Item(c.Value) = ""

Avec le transfert du champ dans un tableau intermédiaire, la création du dictionnaire est + rapide(0,04 sec pour 16.000 lignes au lieu de 0,26 sec)

Sub ListeSansDoublons()
  Set mondico = CreateObject("Scripting.Dictionary")
  a = Range("a2:a" & [a65000].End(xlUp).Row)   ' tableau a(n,1) 
  For i = LBound(a) To UBound(a)
    mondico(a(i, 1)) = ""
  Next i
  [c2].Resize(mondico.Count, 1) = Application.Transpose(mondico.keys)
End Sub

Si les noms sont écrits avec une casse différente

Sub ListeSansDoublons()
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range("a2", [a65000].End(xlUp))
    mondico(UCase(c.Value)) = ""
  Next c
  [C2].Resize(mondico.Count, 1) = Application.Transpose(mondico.keys)
End Sub

Liste sans doublons triée

LSDTriée

Sub ListeSansDoublonsTriée()
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range("a2", [a65000].End(xlUp))
     mondico(c.Value) = ""
  Next c
  [C2].Resize(mondico.Count, 1) = Application.Transpose(mondico.keys)
  [C1].Sort Key1:=[C2], Order1:=xlAscending, Header:=xlYes
End Sub

Compter les éléments différents d'un champ

Pour 10.000 éléments, on obtient 0,015 sec avec le dictionnaire et 3 sec avec Evaluate

Compte éléments différents

Sub ElementsDifferentsDico()
  t = Timer()
  Set d1 = CreateObject("Scripting.Dictionary")
  Tbl = Range("B2:B" & [b65000].End(xlUp).Row)
  For i = 1 To UBound(Tbl)
    d1(Tbl(i, 1)) = ""
  Next i
  MsgBox Timer() - t
  MsgBox d1.Count
End Sub

Avec Evaluate

Sub ElementsDifferentsDicoEvaluate()
  t = Timer()
  Dim Nb As Long, derlig
  derlig = Cells(Rows.Count, 2).End(xlUp).Row
  Nb = Evaluate("SUMPRODUCT(1/COUNTIF(B2:B" & derlig & ",B2:B" & derlig & "))")
  MsgBox Timer() - t
  MsgBox Nb
End Sub

Cumul des montants sans les doublons

Cumul sans les doublons

Sub CumulMontantSansDoublons()
  Set d1 = CreateObject("Scripting.Dictionary")
  Set f1 = Sheets("BD")
  Tbl = f1.[a1].CurrentRegion
  Ttal = 0
  For i = 2 To UBound(Tbl)
    If Not d1.exists(Tbl(i, 1)) Then Ttal = Ttal + Tbl(i, 2): d1(Tbl(i, 1)) = ""
  Next i
  MsgBox Ttal
End Sub

Compter le nombre d'éléments par code

Pour avoir la liste sans doublons et le nombre d'occurences de chaque item.

Compte éléments

Sub CompteItems()
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range("a2", [a65000].End(xlUp))
    mondico(c.Value) = mondico(c.Value) + 1
  Next c
  [c2].Resize(mondico.Count, 1) = Application.Transpose(mondico.keys)
  [d2].Resize(mondico.Count, 1) = Application.Transpose(mondico.items)
  [C1].Sort Key1:=[C2], Order1:=xlAscending, Header:=xlYes
End Sub

Remarque
mondico(c.Value) = mondico(c.Value) + 1 <=>mondico.Item(c.Value) = mondico.Item(c.Value) + 1

Si la colonne A est modifiée, on peut transformer la macro en fonction perso matricielle pour obtenir une maj automatique.

Fonction Compte

Function Compte(champ As Range)
  Application.Volatile
  Set d = CreateObject("Scripting.Dictionary")
  a = champ
  For i = LBound(a) To UBound(a)
     clé = a(i, 1)
     d(clé) = d(clé) + 1
   Next i
   Dim temp()
   ReDim temp(1 To Application.Caller.Rows.Count, 1 To 2)
   i = 1
   For Each c In d.keys
      temp(i, 1) = c
       temp(i, 2) = d(c)
       i = i + 1
   Next
   Compte = temp
End Function

Nombre d'occurences uniques

Items Différents

Function ItemsDifferents(champ)
  Application.Volatile
  Set d1 = CreateObject("Scripting.Dictionary")
  a = champ
  For i = 1 To champ.Count
    If a(i, 1) <> "" Then d1(a(i, 1)) = ""
  Next i
  ItemsDifferents = d1.Count
End Function

Nombre d'occurences uniques avec 1 critère avec fonction personnalisée

Avec une fonction personalisée, le calcul du nombre d'occurences uniques est beaucoup plus rapide.

Items Différents 1 ou 2 Critères
Items Différents 1 Critère Date

Sous total de tableau 1 colonne

Sous Totaux
Sous Totaux2
Fonction Sous Totaux
Regroupe
Merge 2 Tables

Sub SousTotal()
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range("a2", [a65000].End(xlUp))
     mondico(c.Value) = mondico(c.Value) + c.Offset(, 1).Value
  Next c
  [e2].Resize(mondico.Count, 1) = Application.Transpose(mondico.keys)
  [f2].Resize(mondico.Count, 1) = Application.Transpose(mondico.items)
  [E1].Sort Key1:=[E2], Order1:=xlAscending, Header:=xlYes
End Sub

Avec des fonctions standards (cf programme)

Sub TotalCA()
  tablo = [A2:B10]
  b = Somme(tablo, 1, 2)        ' Total des CA par ville
  TriTab b, 2, "D"                    ' Trié en ordre décroissant

  [e2].Resize(UBound(b), 2) = b
End Sub

Sous total de 2 colonnes avec tableaux et indexation par dictionnaire

a/Si le tableau a() n'est pas trié:

Sous Total 2 col

La table b() est indexée par le dictionnaire d1 pour permettre un accès plus rapide à chaque ligne de la table b().

Sub SousTotalNonTrié()
  Set d1 = CreateObject("Scripting.Dictionary")
  a = Range("A2:C" & [a65000].End(xlUp).Row)
  j = 0
  For i = LBound(a) To UBound(a)
    If Not d1.exists(a(i, 1)) Then j = j + 1: d1(a(i, 1)) = j
  Next i
  Dim b(): ReDim b(1 To d1.Count, 1 To UBound(a, 2))
  For ligne = LBound(a) To UBound(a)
    p = d1(a(ligne, 1))
    For k = 2 To UBound(a, 2): b(p, k) = b(p, k) + a(ligne, k): Next k
    b(p, 1) = a(ligne, 1)
  Next ligne
  [E11].Resize(UBound(b), UBound(b, 2)) = b
End Sub

ou

Sub SousTotalNonTrié2()
  Set d1 = CreateObject("Scripting.Dictionary")
  Set d2 = CreateObject("Scripting.Dictionary")
  a = Range("A2:C" & [a65000].End(xlUp).Row)
  For i = LBound(a) To UBound(a)
    d1(a(i, 1)) = d1(a(i, 1)) + a(i, 2)
    d2(a(i, 1)) = d2(a(i, 1)) + a(i, 3)
  Next i
  [E20].Resize(d1.Count) = Application.Transpose(d1.keys)
  [F20].Resize(d1.Count) = Application.Transpose(d1.items)
  [G20].Resize(d1.Count) = Application.Transpose(d2.items)
End Sub

b/Si la table a() est triée:

Sub SousTotalTablo()
  a = Range("A2:C" & [a65000].End(xlUp).Row)
  Dim b(): ReDim b(1 To UBound(a), 1 To UBound(a, 2))
  i = 1: j = 0
  Do While i <= UBound(a)
    j = j + 1: b(j, 1) = a(i, 1)
    Do While a(i, 1) = b(j, 1)
      For k = 2 To 3: b(j, k) = b(j, k) + a(i, k): Next k
        i = i + 1: If i > UBound(a) Then Exit Do
     Loop
   Loop
   [e2].Resize(UBound(b), UBound(b, 2)) = b
End Sub

Sous-total avec plusieurs colonnes

Synthèse tableau plusieurs colonnes
Synthèse tableau plusieurs colonnes2

Sub SousTotalPLusieursColonnes()
  Set f1 = Sheets("données")
  a = f1.Range("A1:E" & f1.[a65000].End(xlUp).Row)
  Ncol = UBound(a, 2) - 1
  Set d1 = CreateObject("Scripting.Dictionary")
  Dim b(): ReDim b(0 To UBound(a), 1 To Ncol + 2)
  Dim c(): ReDim c(0 To Ncol)
  For k = 1 To Ncol: b(0, k + 1) = a(1, k + 1): Next k: b(0, Ncol + 2) = "Total"
  For i = 2 To UBound(a)
    If Not d1.Exists(a(i, 1)) Then d1(a(i, 1)) = d1.Count + 1: p = d1(a(i, 1)): b(p, 1) = a(i, 1) Else p = d1(a(i, 1))
    For k = 1 To Ncol
      b(p, k + 1) = b(p, k + 1) + a(i, k + 1)
      b(p, Ncol + 2) = b(p, Ncol + 2) + a(i, k + 1)
      c(k) = c(k) + a(i, k + 1)
    Next k
  Next i
  f1.[J1].Resize(d1.Count + 1, Ncol + 2) = b
  f1.[J1].Offset(1).Resize(d1.Count, Ncol + 2).Sort key1:=f1.[J1].Offset(1), Order1:=xlAscending, Header:=xlNo
  c(0) = "Total vers": f1.[J1].Offset(d1.Count + 1).Resize(, Ncol) = c
End Sub

Tableau avec plusieurs colonnes espacées.

Synthèse tableau plusieurs colonnes espacées

Autre exemple

Totalisation de la colonne 1 par PartNumber

La table a() n'est pas triée par partNumber. La table b() est indexée par le dictionnaire pour permettre un accès plus rapide à chaque ligne de la table b().

Sous Total Tableau 2D
Sous Total Tableau 2D 2

Sub SousTotal2()
  Set d1 = CreateObject("Scripting.Dictionary")
  a = Range("A2:D" & [a65000].End(xlUp).Row)
  j = 0
  For i = LBound(a) To UBound(a)
    tmp = a(i, 2)
    If Not d1.exists(a(i, 2)) Then j = j + 1: d1(a(i, 2)) = j
  Next i
  Dim b(): ReDim b(1 To d1.Count, 1 To UBound(a, 2))
  For ligne = LBound(a) To UBound(a)
    p = d1(a(ligne, 2))
    b(p, 1) = b(p, 1) + a(ligne, 1)
    For k = 2 To 4: b(p, k) = a(ligne, k): Next k
  Next ligne
  [M2].Resize(UBound(b), UBound(b, 2)) = b
  [A1:D1].Copy [M1]
End Sub

Consolidation de plusieurs tableaux

Consolide Tableaux

Dim d1, d2
Sub consolide2()
  Set d1 = CreateObject("Scripting.Dictionary")
  Set d2 = CreateObject("Scripting.Dictionary")
  a = [E3:G3].Resize([E2].CurrentRegion.Rows.Count - 2)
  totalise a
  a = [I3:K3].Resize([I2].CurrentRegion.Rows.Count - 2)
  totalise a
  [a3].Resize(d1.Count) = Application.Transpose(d1.keys)
  [b3].Resize(d1.Count) = Application.Transpose(d1.items)
  [c3].Resize(d2.Count) = Application.Transpose(d2.items)
End Sub

Sub totalise(a)
  For i = LBound(a) To UBound(a)
    d1(a(i, 1)) = d1(a(i, 1)) + a(i, 2)
    d2(a(i, 1)) = d2(a(i, 1)) + a(i, 3)
  Next i
End Sub

Maj Stock

Nous mettons à jour le stock avec les ventes.

Maj stock
Saisie ventes de produits & maj stock1
Saisie ventes de produits & maj stock2
Saisie ventes de produits & maj stock3
Saisie ventes de produits & maj stock4
Saisie commande de produits & maj stock

Sub majstock()
  Set f = Sheets("stock") ' lecture stock dans dico
  Set d = CreateObject("scripting.dictionary")
  Set Rng = f.Range("A3:A" & f.[A65000].End(xlUp).Row)
  For Each c In Rng
     If c.Value <> "" Then d(c.Value) = c.Offset(, 1)
  Next c
  '---- soustraction des ventes du stock
  Set Rng2 = f.Range("D3:D" & f.[D65000].End(xlUp).Row)
  For Each c In Rng2
    If c.Value <> "" Then d(c.Value) = d(c.Value) - c.Offset(, 1)
  Next c
  f.[A3].Resize(d.Count) = Application.Transpose(d.keys)
  f.[B3].Resize(d.Count) = Application.Transpose(d.items)
End Sub

Fusion de 2 tableaux

Fusion_2014_2015
Fusion_2014_2015_2

Sub fusion()
  Set d1 = CreateObject("Scripting.Dictionary")
  Set f1 = Sheets("ca2014")
  a = f1.Range("A2:B" & f1.[a65000].End(xlUp).Row)
  Set f2 = Sheets("ca2015")
  b = f2.Range("A2:B" & f2.[a65000].End(xlUp).Row)
  n = UBound(a) + UBound(b)
  Dim c: ReDim c(1 To n, 1 To 3)
  m = 0
  For i = LBound(a) To UBound(a)
    If Not d1.exists(a(i, 1)) Then m = m + 1: d1(a(i, 1)) = m: p = m Else p = d1(a(i, 1))
    c(p, 1) = a(i, 1): c(p, 2) = a(i, 2)
  Next i
  For i = LBound(b) To UBound(b)
    If Not d1.exists(b(i, 1)) Then m = m + 1: d1(b(i, 1)) = m: p = m Else p = d1(b(i, 1))
    c(p, 1) = b(i, 1): c(p, 3) = b(i, 2)
  Next i
  Sheets("fusion").[A2].Resize(d1.Count, UBound(c, 2)) = c
End Sub

ou

Sub fusion2()
  Set d1 = CreateObject("Scripting.Dictionary")
  Set d2 = CreateObject("Scripting.Dictionary")
  Set f1 = Sheets("ca2014")
  a = f1.Range("A2:B" & f1.[a65000].End(xlUp).Row)
  Set f2 = Sheets("ca2015")
  b = f2.Range("A2:B" & f2.[a65000].End(xlUp).Row)
  For i = LBound(a) To UBound(a): d1(a(i, 1)) = "": d2(a(i, 1)) = "": Next i
  For i = LBound(b) To UBound(b): d1(b(i, 1)) = "": d2(b(i, 1)) = "": Next i
  For i = LBound(a) To UBound(a): d1(a(i, 1)) = a(i, 2): Next i
  For i = LBound(b) To UBound(b): d2(b(i, 1)) = b(i, 2): Next i
  Sheets("fusion").[A2].Resize(d1.Count) = Application.Transpose(d1.keys)
  Sheets("fusion").[b2].Resize(d1.Count) = Application.Transpose(d1.items)
  Sheets("fusion").[c2].Resize(d1.Count) = Application.Transpose(d2.items)
End Sub

Regroupement par lignes avec sous-totaux (tableau + indexation par dictionnaire)

On regroupe les lignes suivant la 1ere colonne en effectuant un sous total.
On suppose que le tableau a() n'est pas trié.
La table Tbl() est indexée par le dictionnaire pour permettre un accès plus rapide à chaque ligne de la table.

RegroupeSousTotal
Regroupe colonne avec saut de ligne
RegroupeSousTotal Plusieurs champs
RegroupeSousTotal Plusieurs champs clé 2 colonnes
RegroupeSousTotal Plusieurs champs 2
RegroupeSousTotal Plusieurs champs 3

Sub RegroupeLigneCumul()
  Set d1 = CreateObject("Scripting.Dictionary")
  Set f1 = Sheets("données")
  Tbl = f1.[a1].CurrentRegion
  Ncol = UBound(Tbl, 2)
  Dim TblRes(): ReDim TblRes(1 To UBound(Tbl), 1 To Ncol)
  For ligne = 2 To UBound(Tbl)
    crit = Tbl(ligne, 1)
    If d1.exists(crit) Then ligt = d1(crit) Else d1(crit) = d1.Count + 1: ligt = d1.Count
    TblRes(ligt, 1) = crit
    For col = 2 To Ncol
       If Tbl(ligne, col) <> "" Then TblRes(ligt, col - 1) = TblRes(ligt, col - 1) + Val(Tbl(ligne, col))
    Next col
  Next ligne
  Set f2 = Sheets("résultats")
  f1.[a1].Resize(, Ncol).Copy f2.[a1]
  f2.[a2].Resize(d1.Count, Ncol - 1) = TblRes
End Sub

Fusion de lignes doublons

On regroupe toutes les informations des doublons Nom+prénom dans une seule ligne.

Fusion lignes doublons
Fusion lignes doublons avec saut de ligne

Sub RegroupeLigneS()
  Set d1 = CreateObject("Scripting.Dictionary")
  Set f1 = Sheets("BD")
  Set f2 = Sheets("résultats")
  ncol = f1.[a1].CurrentRegion.Columns.Count
  nlig = f1.[a1].CurrentRegion.Rows.Count
  d1.CompareMode = vbTextCompare
  For ligne = 1 To nlig
    crit = f1.Cells(ligne, 1) & f1.Cells(ligne, 2) ' nom+prenom
    d1(crit) = ""
    ligT = Application.Match(crit, d1.keys, 0)
    For col = 1 To ncol
      If f1.Cells(ligne, col) <> "" Then f2.Cells(ligT, col) = f1.Cells(ligne, col).Text
    Next col
    If f1.Cells(ligne, ncol) <> "" Then f1.Cells(ligne, ncol).Copy f2.Cells(ligT, ncol)
  Next ligne
End Sub

Sur cette version, nous fusionnons tous les numéros de tph de chaque personne dans une cellule.

Fusion lignes doublons2

Regroupement dans une cellule

Regroupe prénoms
Regroupe quartiers
Regroupement
Regroupement2
Regroupement avec saut de ligne
Regroupement 2 critères avec saut de ligne

Sub ListeSansDoublons()
   Set mondico = CreateObject("Scripting.Dictionary")
   For Each c In Range("a2", [a65000].End(xlUp))
     If Not mondico.exists(c.Value) Then
        mondico(c.Value) = c.Offset(, 1).Value
     Else
        mondico(c.Value) = mondico(c.Value) & "," & c.Offset(, 1).Value
     End If
  Next c
  [D2].Resize(mondico.Count, 1) = Application.Transpose(mondico.keys)
  [E2].Resize(mondico.Count, 1) = Application.Transpose(mondico.items)
End Sub

Regroupement avec présentation en colonnes

Sub PrésentationColonnes()
  [D2:K100].ClearContents
  Set d = CreateObject("Scripting.Dictionary")
  For Each c In Range("A2:A" & [A65000].End(xlUp).Row)
    d(c.Value) = d(c.Value) & c.Offset(0, 1) & "|"
  Next c
  If d.Count > 0 Then
    [d2].Resize(, d.Count) = d.keys
    i = 0
    For Each c In d.items
       a = Split(c, "|")
       d4].Offset(, i).Resize(UBound(a)) = Application.Transpose(a)
       i = i + 1
    Next c
  End If
End Sub

Statistiques 2 critères

Stat 2 Critères Totaux
Stat 2 Critères Totaux Trié
Stat 2 Critères Maximum
Regroupement 2 Critères Saut de ligne

Sub Stat2DTab()
  Set f = Sheets("BD")
  TblBD = f.Range("A2:C" & f.[A65000].End(xlUp).Row).Value ' Array pour rapidité
  colCrit1 = 1: colCrit2 = 2: colOper = 3             ' Adapter
  Set AdrResult = f.Range("f1")                          ' Adresse résultat
  Set d1 = CreateObject("Scripting.Dictionary")   ' Dictionnaire index pour rapidité
  Set d2 = CreateObject("Scripting.Dictionary")
  Dim TblTot(1 To 100, 1 To 100)
  Dim TblTotLig(1 To 100)
  Dim TblTotCol(1 To 100)
  For i = LBound(TblBD) To UBound(TblBD)
    tmp = TblBD(i, colCrit1): If d1.exists(tmp) Then lig = d1(tmp) Else d1(tmp) = d1.Count + 1: lig = d1.Count
    tmp = TblBD(i, colCrit2): If d2.exists(tmp) Then col = d2(tmp) Else d2(tmp) = d2.Count + 1: col = d2.Count
    TblTot(lig, col) = TblTot(lig, col) + TblBD(i, colOper)
    TblTotLig(lig) = TblTotLig(lig) + TblBD(i, colOper)
    TblTotCol(col) = TblTotCol(col) + TblBD(i, colOper)
  Next i
  AdrResult.Offset(1).Resize(d1.Count, 1) = Application.Transpose(d1.keys) ' titres lignes
  AdrResult.Offset(, 1).Resize(1, d2.Count) = d2.keys          ' titres colonnes
AdrResult.Offset(1, 1).Resize(d1.Count, d2.Count) = TblTot ' stat 2D
AdrResult.Offset(1).Offset(d1.Count, 1).Resize(, d2.Count) = TblTotCol ' totaux colonnes
AdrResult.Offset(1, 1).Offset(, d2.Count).Resize(d1.Count) = Application.Transpose(TblTotLig) ' totaux lignes
End Sub

Avec des fonctions standards (cf programme)

Sub stats()
  tablo = [A2:C11]
  a = Stat2DSomme(tablo, 1, 2, 3)         ' Adapter avec les colonnes choisies
  [F2].Resize(UBound(a), UBound(a, 2)) = a
End Sub

Autre exemple

-La BD est transférée dans une table Tbl(,) pour la rapidité d'accès.
-Les stats sont effectuées dans un tableau Tstat()
-Pour retrouver plus rapidement la ligne et la colonne du tableau Tstat(,) où effectuer le cumul, on indexe celui ci avec 2 dictionnaires d1 et d2.

Stat 2 CritèresTotaux 2

Autre Exemple

On regroupe des icônes en conservant les polices et les couleurs.

Regroupe Icônes

Sub RegroupeIcônes()
  Set f = Sheets("BD")
  BD = f.Range("A2:E" & f.[A65000].End(xlUp).Row).Value    ' 2 colonnes de plus pour les attributs
  colCrit1 = 1
  colCrit2 = 2
  colOper = 3
  colAttribut = 4
  Set AdrRes = f.Range("G1")                ' Adresse résultat
  For i = LBound(BD) To UBound(BD)     ' Remplissage des Attributs
    BD(i, colAttribut) = f.Cells(i + 1, colOper).Font.ColorIndex
    BD(i, colAttribut + 1) = f.Cells(i + 1, colOper).Font.Name
  Next i
  AdrRes.CurrentRegion.ClearContents
  Set d1 = CreateObject("Scripting.Dictionary")   ' Dictionnaire index pour rapidité
  Set d2 = CreateObject("Scripting.Dictionary")
  For i = LBound(BD) To UBound(BD)
    tmp = BD(i, colCrit1): If d1.exists(tmp) Then lig = d1(tmp) Else d1(tmp) = d1.Count + 1: lig = d1.Count
    tmp = BD(i, colCrit2): If d2.exists(tmp) Then col = d2(tmp) Else d2(tmp) = d2.Count + 1: col = d2.Count
    x = Len(AdrRes.Offset(lig, col))
    AdrRes.Offset(lig, col).Characters(Start:=x + 1, Length:=1).Text = BD(i, colOper)
    AdrRes.Offset(lig, col).Characters(Start:=x + 1, Length:=1).Font.ColorIndex = BD(i, colAttribut)
    AdrRes.Offset(lig, col).Characters(Start:=x + 1, Length:=1).Font.Name = BD(i, colAttribut + 1)
  Next i
  AdrRes.Offset(1).Resize(d1.Count) = Application.Transpose(d1.keys)  ' titres lignes
  AdrRes.Offset(, 1).Resize(, d2.Count) = d2.keys                               ' titres colonnes
  '--- tri lignes & colonnes
  Set Rng = AdrRes.Resize(d1.Count + 1, d2.Count + 1)
  Rng.Offset(1).Resize(Rng.Rows.Count - 1, Rng.Columns.Count).Sort key1:=Rng.Cells(2, 1), _
    Order1:=xlAscending, Header:=xlNo, MatchCase:=False, Orientation:=xlSortColumns
  Rng.Offset(, 1).Resize(Rng.Rows.Count, Rng.Columns.Count - 1).Sort key1:=Rng.Cells(1, 2), _
    Order1:=xlAscending, Header:=xlNo, MatchCase:=False, Orientation:=xlSortRows
End Sub

Regroupe Couleurs

Fonction de consolidation Multi-Zones

Cette fonction permet de consolider plusieurs tableaux dans un autre.

FonctionMergeMZ

Function MergeMZ(champ)
  Application.Volatile
  Set d = CreateObject("Scripting.Dictionary")
  For i = 1 To champ.Areas.Count ' parcours des zones du champ multi-zones
    For j = 1 To champ.Areas(i).Rows.Count ' parcours des éléments d'une zone
       If champ.Areas(i).Cells(j, 1) <> "" Then
          temp = champ.Areas(i).Cells(j, 1)
         d.Item(temp) = d.Item(temp) + champ.Areas(i).Cells(j, 2)
       End If
    Next j
  Next i
  Dim b()
  ReDim b(1 To Application.Caller.Rows.Count, 1 To 2) ' table pour retour
  i = 0
  For Each c In d.keys
    i = i + 1
    b(i, 1) = c
    b(i, 2) = d(c)
  Next c
  MergeMZ = b
End Function

Transformation d'un tableau en BD

TransformationTableauBD

Sub transforme()
  Set d1 = CreateObject("scripting.dictionary")
  For Each c In Range("a2:a" & [a65000].End(xlUp).Row)
    a = Split(c.Offset(, 1).Value, ";")
    For Each m In a: d1(Trim(m)) = c: Next m
  Next c
  [E2].Resize(d1.Count) = Application.Transpose(d1.keys)
  [D2].Resize(d1.Count) = Application.Transpose(d1.items)
End Sub

Transformation d'une BD en Tableau

TransformeBDTableau

Sub Regroupe2()
  Set d = CreateObject("Scripting.Dictionary")
  For Each c In Range("a2", [a65000].End(xlUp))
    d(c.Value) = d(c.Value) & c.Offset(0, 1) & "|" & c.Offset(0, 2) & "|"
  Next c
  [F2].Resize(d.Count) = Application.Transpose(d.keys)
  [G2].Resize(d.Count) = Application.Transpose(d.items)
  Application.DisplayAlerts = False
  Range("G2").Resize(d.Count).TextToColumns Other:=1, OtherChar:="|"
  Cells.EntireRow.AutoFit
End Sub

Autre exemple

BD Tableau

Sub BDTableau()
  Set d1 = CreateObject("Scripting.Dictionary")
  Set d2 = CreateObject("Scripting.Dictionary")
  Dim Tbl(1 To 100, 1 To 100)
  For Each c In Range("a2:a" & [A65000].End(xlUp).Row)
    If d1.exists(c.Value) Then lig = d1(c.Value) Else d1(c.Value) = d1.Count + 1: lig = d1.Count
    tmp = c.Offset(, 1)
    If d2.exists(tmp) Then col = d2(tmp) Else d2(tmp) = d2.Count + 1: col = d2.Count
    Tbl(lig, col) = c.Offset(, 2)
  Next c
  [f2].Resize(d1.Count, 1) = Application.Transpose(d1.keys)
  [g1].Resize(1, d2.Count) = d2.keys
  [g2].Resize(d1.Count, d2.Count) = Tbl
End Sub

Performance

Pour tester la performance de l'objet Dictionary, nous créons une liste de nombres aléatoires sans doublons
Nous obtenons un temps de 0,04 seconde pour 10.000 items

Sub Dictionnaire()
  t = Timer
  Set mondico = CreateObject("Scripting.Dictionary")
  n = 10000
  For i = 1 To n
    aléa = Int(Rnd * 10000)
    mondico(aléa) = mondico(aléa) + 1
  Next i
  MsgBox Timer - t
  [A1].Resize(mondico.Count) = Application.Transpose(mondico.keys)
  [B1].Resize(mondico.Count) = Application.Transpose(mondico.items)
End Sub

Comparaison Dictionary/Collection

Sub DicoSansDoublons()
  t = Timer()
  Set mondico = CreateObject("Scripting.Dictionary")
  n = 40000
  For i = 1 To n
    temp = Int(Rnd * n)
    mondico(temp) = ""
  Next i
  [a2].Resize(mondico.Count) = Application.Transpose(mondico.keys)
  MsgBox Timer() - t ' 0,17 sec
End Sub

Sub CollectionSansDoublons()
   Dim t, i As Long, n As Long, temp As Long
   t = Timer()
   Dim Maliste As New Collection
   On Error Resume Next
   n = 40000
   For i = 1 To n
     temp = Int(Rnd * n)
     Maliste.Add Item:=temp, key:=CStr(temp)
   Next i
   On Error GoTo 0
   Dim a()
   ReDim a(1 To n)
   For i = 1 To Maliste.Count
     a(i) = Maliste(i)
   Next i
   [a2].Resize(Maliste.Count) = Application.Transpose(a)
   MsgBox Timer() - t ' 10 sec
End Sub

Ne surtout pas trier directement une collection (32 sec pour 1.200 éléments). Il faut passer par un tableau.

Comparaison Dictionary/Tableau/Find

L'accès à une clé d'un dictionnaire est 100 fois + rapide qu'une recherche séquentielle dans un tableau (l'accès aux clés d'un dictionnaire doit se faire par hash-code)

CompareTableauDictionary
Compare Dictionary Collection Recherche Dichotomique

Sub RechercheTableau()
  a = [A1:b20000]
  t = Timer()
  For j = 15000 To 16000 Step 2 ' 500 recherches= 4 sec
    x = "Nom" & Trim(Str(j))
    For i = 1 To 20000
      If a(i, 1) = x Then
        y = a(i, 2)
      End If
     Next i
   Next j
   MsgBox Timer() - t
End Sub

Sub RechercheDico()
  Set mondico = CreateObject("scripting.dictionary")
  a = [A1:b20000]
  For i = 1 To 20000
    mondico(A(i, 1)) = A(i, 2)
  Next i
  t = Timer()
  For j = 15000 To 16000 Step 2 ' 500 recherches= 0,015 sec
    x = "Nom" & Trim(Str(j))
    y = mondico(x)
  Next j
  MsgBox Timer() - t
End Sub

Sub RechercheFind()
  Set mondico = CreateObject("scripting.dictionary")
  t = Timer()
  For j = 15000 To 16000 Step 2 ' 500 recherches= 2,65 sec
    x = "Nom" & Trim(Str(j))
    Set result = [A1:A20000].Find(what:=x)
       y = result.Offset(, 1)
   Next j
  MsgBox Timer() - t
End Sub

Fonction perso RechvM() matricielle plus rapide que Recherchev() classique

RechvM
RechvMultCol

Si on modifie les 2.600 valeurs cherchées dans un tableau de 20.000 items,
le temps de recalcul est de 0,2 seconde (3,9 sec pour recherchev())

-Sélectionner G2:G2673
=RechvM(F2:F2673;matable;2)
-Valider avec maj+ctrl+entrée

Function RechvM(clé As Range, champ As Range, colResult)
  Application.Volatile
  Set d = CreateObject("Scripting.Dictionary")
  a = champ.Value
  b = clé.Value
  For i = LBound(a) To UBound(a)
    d(a(i, 1)) = a(i, colResult)
  Next i
  Dim temp()
  ReDim temp(LBound(b) To UBound(b))
  For i = LBound(b) To UBound(b)
    temp(i) = d(b(i, 1))
  Next i
  RechvM = Application.Transpose(temp)
End Function

Cette version renvoi un message d'erreur si la valeur cherchée n'existe pas.

Function RechvM(clé As Range, champ As Range, colResult, messageErreur)
  Application.Volatile
  Set d = CreateObject("Scripting.Dictionary")
  a = champ.Value
  b = clé.Value
  For i = LBound(a) To UBound(a)
    d(a(i, 1)) = a(i, colResult)
  Next i
  Dim temp()
  ReDim temp(LBound(b) To UBound(b))
  For i = LBound(b) To UBound(b)
    If d(b(i, 1)) <> "" Then temp(i) = d(b(i, 1)) Else temp(i) = messageErreur
  Next i
  RechvM = Application.Transpose(temp)
End Function

Dictionary pour remplacer Sommeprod()

Comment améliorer Sommeprod() lorsque cette fonction

- travaille sur des champs de taille importante
- est recopiée x1000 fois

Sur l'exemple en PJ, avec une fonction perso matricielle, on passe d'un temps de recalcul de 3 sec à 0,05 sec pour 4.000 lignes

=SOMMEPROD((dates=A2)*(numero=B2)) ou =CombienFois(numero; dates)

CombienPerso
CombienSommeProd
MatricielPerso

Alimenter une liste déroulante triée sans les doublons

On alimente un combobox avec une liste triée sans doublons.

FormLSD

Option Compare Text
Dim f, dico
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Set dico = CreateObject("Scripting.Dictionary")
  For Each c In f.Range("B2:B" & f.[B65000].End(xlUp).Row)
     dico(c.Value) = ""
  Next c
  temp = dico.keys
  Call tri(temp, LBound(temp), UBound(temp))
  Me.ComboBox1.List = temp
End Sub

Private Sub ComboBox1_Change()
  Me.ListBox1.Clear
  For Each c In f.Range("B2:B" & f.[B65000].End(xlUp).Row)
     If c = Me.ComboBox1 Then Me.ListBox1.AddItem c.Offset(, -1)
  Next c
End Sub

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

La lecture des données du tableur peut être accélérée en utilisant un tableau a()

Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Set MonDico = CreateObject("Scripting.Dictionary")
  a = f.Range("B2:B" & f.[B65000].End(xlUp).Row)     ' tableau (n,1)
  For i = LBound(a) To UBound(a)
    MonDico(a(i, 1)) = ""
  Next i
  temp = MonDico.keys
  Call tri(temp, LBound(temp), UBound(temp))
  Me.ComboBox1.List = temp
End Sub

S'il y a des Majuscules/Minuscules

MonDico(Ucase(c.Value) )= ""

ou

MonDico(Application.Proper(c.Value) )= ""

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

Dico.Ajout clé,item

Ajoute une clé et la valeur associée

Dico.Existe(clé)

Teste l'existence d'une clé

Dico.Item(clé)

Donne l'item de la clé

Dico.Count(clé)

Donne le nombre de clés

Dico.Sup clé

Suprime la clé

Dico.ListeCles

Renvoie un tableau vertical des clés

Dico.ListeItems

Renvoie un tableau vertical des items

Dico.Cle(indice)

Donne la clé pour un indice (1,2,3,...)

Dico.Tri

Tri les clé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

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

Public Property Get count()
  count = xn
End Property

Public 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

Public 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

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

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

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

Public 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

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

Classe Base de données

La classe BD gère des enregistrements.
Elle permet d'ajouter, supprimer et trier des enregistrements.
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.

ClasseBD Dictionary
ClasseBD Collection

Repérage de doublons

On veut colorier les doublons.

Sub ColoriageDoublons()
  [A:A].Interior.ColorIndex = xlNone
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range("a2", [a65000].End(xlUp))
    If c<>"" then  mondico.Item(c.Value) = mondico.Item(c.Value) + 1
  Next c
  For Each c In Range("a2", [a65000].End(xlUp))
    If mondico.Item(c.Value) > 1 Then c.Interior.ColorIndex = 4
  Next c
End Sub

Pour 12.000 lignes, avec la fonction Nb.Si(), on obtient un temps de 15 secondes au lieu de 0,5 seconde avec l'objet Dictionary.

Sub ColoriageDoublonsNbSi
  Application.ScreenUpdating = False
  [a:a].Interior.ColorIndex = xlNone
  For Each c In Range("a2", [a65000].End(xlUp))
     If Application.CountIf([a2:a12000], c) > 1 Then c.Interior.ColorIndex = 4
  Next c
End Sub

Ci dessous, chaque groupe a une couleur différente

ColorGroup
ColorGroup2
ColorGroupComment
ColoriageDoublonsCommentMultiFeuilles

Sub GroupColor()
  couleurs = Array(1, 3, 4, 6, 7, 8, 14, 15, 17, 20, 22, 24, 26, 27, 28, 33, 34, 35, 36, 37, 38, 39, 40, 42, 43, 44, 45, 46, 50, 53)
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range("a2", [a65000].End(xlUp))
    If c <> "" Then mondico.Item(c.Value) = mondico.Item(c.Value) + 1
  Next c
  For Each c In Range("a2", [a65000].End(xlUp))
   If c <> "" Then
     nocoul = (Application.Match(c.Value, mondico.keys, 0)) Mod UBound(couleurs)
     If mondico.Item(c.Value) > 1 Then c.Interior.ColorIndex = couleurs(nocoul)
   End If
  Next c
End Sub

Doublons 2 critères

Le test de doublon se fait sur les colonnes A et C.

Doublons 2 Critères

Sub GroupColor2CritèresColAColC()
  couleurs = Array(1, 3, 4, 6, 7, 8, 14, 15, 17, 20, 22, 24, 26, 27, 28, 33, 34, 35, 36, 37, 38, 39, 40, 42, 43, 44,    45, 46, 50, 53)
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range("a2", [a65000].End(xlUp))
    clé = c.Value & c.Offset(, 2)
    mondico.Item(clé) = mondico.Item(clé) + 1
  Next c
  For Each c In Range("a2", [a65000].End(xlUp))
    clé = c.Value & c.Offset(, 2)
    nocoul = (Application.Match(clé, mondico.keys, 0)) Mod UBound(couleurs)
    If mondico.Item(clé) > 1 Then c.Resize(, 4).Interior.ColorIndex = couleurs(nocoul)
  Next c
End Sub

Doublons 2 critères avec indication des nos de lignes

ColorGroup3
ColorGroup4

Sub GroupColor()
  [A1].CurrentRegion.Interior.ColorIndex = xlNone
  Set d = CreateObject("Scripting.Dictionary")
  Set d2 = CreateObject("Scripting.Dictionary")
  For Each c In Range("A1", [A65000].End(xlUp))
    d.Item(c.Value & c.Offset(, 1)) = d.Item(c.Value & c.Offset(, 1)) + 1
    d2.Item(c.Value & c.Offset(, 1)) = d2.Item(c.Value & c.Offset(, 1)) & CStr(c.Row) & "-"
  Next c
  [A1].CurrentRegion.ClearComments
  For Each c In Range("A1", [A65000].End(xlUp))
    If d.Item(c.Value & c.Offset(, 1)) > 1 Then
       c.Resize(, 2).Interior.ColorIndex = (Application.Match(c.Value & c.Offset(, 1), d.keys, 0) + 2) Mod 55
       c.AddComment
       temp = c.Value & c.Offset(, 1).Value
       c.Comment.Text Text:=Left(d2.Item(temp), Len(d2.Item(temp)) - 1)
       c.Comment.Shape.Left = c.Offset(, 1).Left + 30
       c.Comment.Shape.TextFrame.AutoSize = True
       c.Comment.Visible = True
     End If
   Next c
   [A:A].SpecialCells(xlCellTypeComments).Copy Sheets("Doublons").[A1]
   [A:A].SpecialCells(xlCellTypeComments).Offset(, 1).Copy Sheets("Doublons").[B1]
   Sheets("Doublons").Select
End Sub

Fonction liste sans doublons triée

Cette fonction personalisée matricielle donne une liste triée sans doublons (x100 fois +rapide qu'un tri matriciel)

Dans le tableur

-Sélectionner D2:D14
=sansdoublonstrié(A2:B11)
-valider avec maj+Ctrl+Entrée

Fonction Sans Doublons Triée
FonctionTri
FonctionSansDoublonsTriéeMultiZones
FonctionSansDoublonsTriéeMultiFeuilles

Option Compare Text
Function SansDoublonsTrié(champ As Range)
  Set mondico = CreateObject("Scripting.Dictionary")
  temp = champ
  For Each c In temp
    If c <> "" Then mondico(c) = ""
  Next c
  Dim b()
  ReDim b(1 To Application.Caller.Rows.Count)
  i = 1
  For Each c In mondico.keys
     b(i) = c
     i = i + 1
  Next
  Call tri(b, 1, mondico.Count)
  SansDoublonsTrié = Application.Transpose(b)
End Function

Repérer les doublons entre 2 colonnes

Repérage des doublons entre 2 colonnes

Doublons 2 colonnesSimple

Sub DoublonsRapide2col()
  Set d1 = CreateObject("Scripting.Dictionary")
  Set d2 = CreateObject("Scripting.Dictionary")
  Set plage1 = Range("A1", [a65000].End(xlUp))
  Set plage2 = Range("B1", [B65000].End(xlUp))
  [A:B].Interior.ColorIndex = xlNone
  For Each c In plage1
    If c <> "" Then d1(c.Value) = ""
  Next c
  For Each c In plage2
    If d1.exists(c.Value) Then c.Interior.ColorIndex = 3
    If c <> "" Then d2(c.Value) = ""
  Next c
  For Each c In plage1
    If d2.exists(c.Value) Then c.Interior.ColorIndex = 4
  Next c
End Sub

Repérage de tous les doublons (entre 2 colonnes + doublons dans chaque colonne)

Sub DoublonsRapideTous()
  Set d1 = CreateObject("Scripting.Dictionary")
  Set d2 = CreateObject("Scripting.Dictionary")
  Set plage1 = Range("A1", [a65000].End(xlUp))
  Set plage2 = Range("B1", [B65000].End(xlUp))
  [A:B].Interior.ColorIndex = xlNone
  For Each c In plage1
     If c <> "" Then d1(c.Value) = d1(c.Value) + 1
  Next c
  For Each c In plage2
  If c <> "" Then d2(c.Value) = d2(c.Value) + 1
    If d1.exists(c.Value) Then c.Interior.ColorIndex = 3
  Next c
  For Each c In plage1
    If d2.exists(c.Value) Then c.Interior.ColorIndex = 4
    If d1(c.Value) > 1 Then c.Interior.ColorIndex = 4
  Next c
  For Each c In plage2
    If d2(c.Value) > 1 Then c.Interior.ColorIndex = 3
  Next c
End Sub

Chaque groupe de doublons a une couleur différente

Doublons 2 colonnesCoulDiff

Sub DoublonsEntre2ColonnesCoulDiff()
  Set d = CreateObject("Scripting.Dictionary")
  couleurs = Array(3, 4, 6, 7, 8, 15, 17, 20, 22, 24, 26, 27, 28, 33, 34, 35, 36, 37, 38, 39, 40, 42, 43, 44, 45, 46, 50, 53)
  Set plage1 = Range("A2:A" & [a65000].End(xlUp).Row)
  Set plage2 = Range("B2:B" & [b65000].End(xlUp).Row)
  Union(plage1, plage2).Interior.ColorIndex = xlNone
  For Each C In plage1
     d.Item(C.Value) = d.Item(C.Value) & C.Row & "-"
  Next C
  For Each C In plage2
     If d.exists(C.Value) Then
       nocoul = (Application.Match(C.Value, d.keys, 0)) Mod UBound(couleurs)
       C.Interior.ColorIndex = couleurs(nocoul)
       a = Split(d.Item(C.Value), "-")
       For k = LBound(a) To UBound(a) - 1
         tmp = a(k) - plage1.Row + 1
         plage1(tmp).Interior.ColorIndex = couleurs(nocoul)
       Next k
     End If
   Next C
End Sub

Doublons 2 colonneCommentaire

Indique les no des lignes qui contiennent des doublons.

Liste des doublons en colonne A et liste des doublons en colonne B

Sub ListeDoublonsColA()
  Set d1 = CreateObject("Scripting.Dictionary")
  Set d2 = CreateObject("Scripting.Dictionary")
  For Each c In Range([a2], [a65000].End(xlUp))
    If c <> "" And d1.exists(c.Value) Then d2(c.Value) = d1(c.Value) & c.Address & "-"
    d1(c.Value) = d1(c.Value) & c.Address & "-"
  Next c
  If d2.Count > 0 Then
    [J2].Resize(d2.Count, 1) = Application.Transpose(d2.keys)
    [K2].Resize(d2.Count, 1) = Application.Transpose(d2.Items)
  End If
End Sub

Liste des doublons entre 2 colonnes

Sub DoublonsEntre2ColonnesRapport2()
  Set d1 = CreateObject("Scripting.Dictionary")
  Set plage1 = Range("a2:a" & [a65000].End(xlUp).Row)
  Set plage2 = Range("b2:b" & [b65000].End(xlUp).Row)
  For Each c In plage2
     d1.Item(c.Value) = d1.Item(c.Value) & c.Address & "-"
  Next c
  I = 2
  For Each c In plage1
    If d1.exists(c.Value) Then
       Cells(I, "P") = c
       Cells(I, "Q") = c.Address
       Cells(I, "R") = d1.Item(c.Value)
       I = I + 1
    End If
  Next c
End Sub

Fonction matricielle ExtraitCoul

Cette fonction personalisée matricielle extrait une liste des cellules de la couleur choisie.

Dans le tableur

-Sélectionner C2:C11
=ExtraitCoul(A2:A11)
-valider avec maj+Ctrl+Entrée

FonctionExtraitCoul
FonctionExtraitGras

Choix successifs (listes différence)

On ne peut pas choisir plusieurs fois la même option.

ChoixSuccessifs



Dim liste, n
Private Sub UserForm_Initialize()
  n = 4
  creelistedispo
End Sub

Sub creelistedispo()
  Set f = Sheets("BD")
  Set liste = CreateObject("Scripting.Dictionary")
  For Each c In f.Range("a2:a" & f.[a65000].End(xlUp).Row).Value
    liste(c) = ""
  Next
  For i = 1 To n
    If Me("combobox" & i).Value <> "" Then liste.Remove (Me("combobox" & i).Value)
  Next i
  For i = 1 To n: Me("ComboBox" & i).List = liste.keys: Next
End Sub

Private Sub ComboBox1_Click()
  creelistedispo
End Sub

Private Sub ComboBox2_Click()
  creelistedispo
End Sub

Private Sub ComboBox3_Click()
  creelistedispo
End Sub

Private Sub ComboBox4_Click()
  creelistedispo
End Sub

Suppression de doublons dans une BD

0,23 sec pour 10.000 éléments

SupDoublonsDictionary

Sub SupDoublonsColA()
  Application.ScreenUpdating = False
  Set f1 = Sheets("BD")
  a = f1.Range("A1").CurrentRegion.Value
  Dim c()
  ReDim c(1 To UBound(a, 1), 1 To UBound(a, 2))
  ligne = 1
  Set mondico = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(a)
    If Not mondico.exists(a(i, 1)) Then
      mondico.Add a(i, 1), 1
      For k = 1 To UBound(a, 2): c(ligne, k) = a(i, k): Next k
      ligne = ligne + 1
    End If
  Next
  Sheets("resultat").[A1].Resize(mondico.Count, UBound(a, 2)) = c
End Sub

Suppression de lignes

On veut supprimer les lignes dont les 5 premiers caractères appartiennent à l'ensemble 01517,01521,...

SupLignes

Sub supLignes()
  Application.ScreenUpdating = False
  Set Dico = CreateObject("Scripting.Dictionary")
  For Each c In Sheets("trie").[A1].CurrentRegion: Dico(c.Text) = "": Next c
  i = 1
  Set f = Sheets("BD")
    Do While f.Cells(i, 1) <> ""
       If Dico.Exists(Left(f.Cells(i, 1), 5)) Then f.Rows(i).Delete Else i = i + 1
    Loop
End Sub

Liste des doublons

On veut la liste des éléments de la colonne A qui sont en double.

Set MonDico = CreateObject("Scripting.Dictionary")
Set MonDico2 = CreateObject("Scripting.Dictionary")
For Each c In Range([a2], [a65000].End(xlUp))
  If MonDico.exists(c.Value) Then MonDico2.Item(c.Value) = ""
  MonDico.Item(c.Value) = ""
Next c
If MonDico2.Count > 0 Then [E2].Resize(MonDico2.Count, 1) = Application.Transpose(MonDico2.keys)

liste des doublons sur 2 critères

Liste Doublons 2 critères

Sub ListeDoublons()
  Set MonDico = CreateObject("Scripting.Dictionary")
  Set mondico2 = CreateObject("Scripting.Dictionary")
  For Each c In Range([a2], [a65000].End(xlUp))
    tmp = c & " " & c.Offset(, 1)
    If MonDico.exists(tmp) Then mondico2.Item(tmp) = c.Row
   MonDico.Item(tmp) = ""
 Next c
 If mondico2.Count > 0 Then [E2].Resize(mondico2.Count, 1) = Application.Transpose(mondico2.keys)
 i = 2
 For Each c In mondico2.keys
   Cells(i, "g") = Cells(mondico2(c), 1)
   Cells(i, "h") = Cells(mondico2(c), 2)
    i = i + 1
 Next c
End Sub

Liste des non doublons (valeurs uniques)

Liste des non doublons (0,4sec pour 10.000 éléments)

Set mondico = CreateObject("Scripting.Dictionary")
For Each c In Range("a2", [a65000].End(xlUp))
  mondico.Item(c.Value) = mondico.Item(c.Value) + 1
Next c
Set mondico2 = CreateObject("Scripting.Dictionary")
For Each c In mondico.keys
   If mondico(c) = 1 Then mondico2(c) = ""
Next c
If mondico2.Count > 0 Then [c2].Resize(mondico2.Count, 1) = Application.Transpose(mondico2.keys)

Liste Non Doublons 3 critères

Sub NonDoublons()
  Set d = CreateObject("Scripting.Dictionary")
  Tbl = Range("a2:c" & [a65000].End(xlUp).Row)
  For i = LBound(Tbl) To UBound(Tbl)
     clé = Tbl(i, 1) & "|" & Tbl(i, 2) & "|" & Tbl(i, 3)
     d(clé) = d(clé) + 1
   Next i
   j = 0
   Dim b(): ReDim b(1 To d.Count, 1 To 3)
   For Each c In d.keys
      If d(c) = 1 Then
         j = j + 1
         a = Split(c, "|")
         b(j, 1) = a(0): b(j, 2) = a(1): b(j, 3) = a(2)
      End If
   Next c
   [e2].Resize(j, 3) = b
End Sub

Ou Exclusif entre 2 listes

On veut la liste de ceux qui n'existent pas dans les 2 listes

Ou Exclusif 2 listes

Compter le nombre de nos de conteneurs différents pour un service

FonctionNbSansDoublonsCritere

Dans le tableur, nous utilisons la fonction peronnalisée:

=NbSansdoublonsCritere($A$2:$A$22;$B$2:$B$22;D2)

Function NBSansDoublonsCritere(champ, champcritere, critere)
  Set MonDico = CreateObject("Scripting.Dictionary")
  For i = 1 To champ.Count
    If UCase(champcritere(i).Value) = UCase(critere) Then MonDico(champ(i).Value) = ""
  Next i
  NBSansDoublonsCritere = MonDico.Count
End Function

Eléments communs à 2 listes

0,5 seconde pour 2 listes de 10.000 éléments.

Eléments Communs
Eléments Communs2
Compare 2 Champs
Donnees Manquantes Liste

Sub Communs()
  a = Range("A2:A" & [A65000].End(xlUp).Row)
  Set MonDico1 = CreateObject("Scripting.Dictionary")
  For Each c In a
    MonDico1(c) = ""
  Next c
  b = Range("C2:C" & [C65000].End(xlUp).Row)
  Set MonDico2 = CreateObject("Scripting.Dictionary")
  For Each c In b
    If MonDico1.exists(c) Then If Not MonDico2.exists(c) Then MonDico2(c) = ""
  Next c
  [G2].Resize(MonDico2.Count, 1) = Application.Transpose(MonDico2.keys)
End Sub


Sub Fusion()
  Set MonDico = CreateObject("Scripting.Dictionary")
  a = Range("A2:A" & [A65000].End(xlUp).Row)
  b = Range("C2:C" & [C65000].End(xlUp).Row)
  For Each c In a
    MonDico(c) = ""
  Next c
  For Each c In b
    MonDico(c) = ""
  Next c
  [E2].Resize(MonDico.Count, 1) = Application.Transpose(MonDico.keys)
End Sub

Sub Liste2_Liste1()
  a = Range("A2:A" & [A65000].End(xlUp).Row)
  Set MonDico1 = CreateObject("Scripting.Dictionary")
  For Each c In a
    MonDico1(c) = ""
  Next c
  b = Range("C2:C" & [C65000].End(xlUp).Row)
  Set MonDico2 = CreateObject("Scripting.Dictionary")
  For Each c In b
    If Not MonDico1.exists(c) Then MonDico2(c) = ""
  Next c
  [I2].Resize(MonDico2.Count, 1) = Application.Transpose(MonDico2.keys)
End Sub

Sub Liste1_Liste2()
  a = Range("C2:C" & [C65000].End(xlUp).Row)
  Set MonDico1 = CreateObject("Scripting.Dictionary")
  For Each c In a
    MonDico1(c) = ""
  Next c
  b = Range("A2:A" & [A65000].End(xlUp).Row)
  Set MonDico2 = CreateObject("Scripting.Dictionary")
  For Each c In b
    If Not MonDico1.exists(c) Then MonDico2(c) = ""
  Next c
  [K2].Resize(MonDico2.Count, 1) = Application.Transpose(MonDico2.keys)
End Sub

Communs à 2 listes avec accents

Les mêmes noms sont orthographiés avec ou sans accent.

ComunsAccents

Sub Communs2Listes()
   Set f = Sheets("BD")
   Set d1 = CreateObject("Scripting.Dictionary")
   Set d2 = CreateObject("Scripting.Dictionary")
   For Each c In f.Range("A2:A" & [A65000].End(xlUp).Row): d1(sansAccent(c.Value)) = "": Next c
   For Each c In f.Range("c2:c" & [c65000].End(xlUp).Row)
     If d1.Exists(sansAccent(c.Value)) Then d2(sansAccent(c.Value)) = ""
   Next c
   f.[E2:E1000].ClearContents
   f.[E2].Resize(d2.Count) = Application.Transpose(d2.keys)
   f.[E2].Sort Key1:=f.[E2], Order1:=xlAscending, Header:=xlYes
End Sub

Function sansAccent(chaine)
  codeA = "ÉÈÊËÔéèêëàçùôûïî"
  codeB = "EEEEOeeeeacuouii"
  temp = chaine
  For i = 1 To Len(temp)
    p = InStr(codeA, Mid(temp, i, 1))
    If p > 0 Then Mid(temp, i, 1) = Mid(codeB, p, 1)
  Next
sansAccent = temp
End Function

Eléments communs à 2 listes avec 2 colonnes

Communs 2 listes
Communs 2 listes 2

Sub Communs()
  Set f1 = Sheets("feuil1")
  Set f2 = Sheets("feuil2")
  Set MonDico1 = CreateObject("Scripting.Dictionary")
  For Each c In f1.Range("A2:A" & f1.[A65000].End(xlUp).Row)
    MonDico1(c & " " & c.Offset(, 1)) = ""
  Next c
  Set MonDico2 = CreateObject("Scripting.Dictionary")
  For Each c In f2.Range("A2:A" & f2.[A65000].End(xlUp).Row)
    tmp = c & " " & c.Offset(, 1)
    If MonDico1.exists(tmp) Then If Not MonDico2.exists(tmp) Then MonDico2(tmp) = ""
  Next c
  f2.[E2].Resize(MonDico2.Count, 1) = Application.Transpose(MonDico2.keys)
End Sub

Eléments communs à plusieurs colonnes

On veut la liste des éléments communs aux colonnes d'un champ.

-Sélectionner G2:G8
=communs(A2:E12)
-Valider avec Maj+ctrl+entrée

Communs

Function communs(champ)
  Set mondico1 = CreateObject("Scripting.Dictionary")
  For Each c In Application.Index(champ, , 1)
    mondico1.Item(c.Value) = c.Offset(, 1).Value
  Next
  For col = 2 To champ.Columns.Count
    Set mondico2 = CreateObject("Scripting.Dictionary")
    For Each c In Application.Index(champ, , col)
      If mondico1.Exists(c.Value) Then mondico2(c.Value) = 1
    Next c
    Set mondico1 = mondico2
  Next col
  i = 1
  ReDim temp(1 To champ.Rows.Count)
  i = 1
  For Each c In mondico2.keys
    temp(i) = c
  i = i + 1
  Next
  communs = Application.Transpose(temp)
End Function

Liste des abréviations sans doublons

Sub Essai()
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range("B2", [B65000].End(xlUp))
    If Not mondico.Exists(c.Value) Then mondico.Add c.Value, Left(c.Offset(0, -1), InStr(c.Offset(0, -1), "-") - 1)
  Next c
  [E2].Resize(mondico.Count, 1) = Application.Transpose(mondico.keys)
  [F2].Resize(mondico.Count, 1) = Application.Transpose(mondico.items)
End Sub

Liste des d'items sans doublons et nombre d'items

Occurences

Sub Essai()
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range("a2", [a65000].End(xlUp))
    mondico.Item(c.Value) = mondico.Item(c.Value) + 1
  Next c
  [c2].Resize(mondico.Count, 1) = Application.Transpose(mondico.keys)
  [d2].Resize(mondico.Count, 1) = Application.Transpose(mondico.items)
End Sub

Sub Essai2()
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range("a2", [a65000].End(xlUp))
    mondico.Item(c.Value) = mondico.Item(c.Value) + 1
  Next c
  a = mondico.keys
  b = mondico.items
  For i = LBound(a) To UBound(a)
    Cells(i + 2, 6) = a(i) & "*" & b(i)
  Next i
End Sub

Sub Essai3()
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range("a2", [a65000].End(xlUp))
    mondico.Item(c.Value) = mondico.Item(c.Value) + 1
  Next c
  i = 2
  For Each c In mondico.keys
    Cells(i, 8) = c & "*" & mondico.Item(c)
    i = i + 1
  Next c
End Sub

Sub Essai4()
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range("a2", [a65000].End(xlUp))
    mondico.Item(c.Value) = c.Value & " * " & Val(Right(mondico(c.Value), 3)) + 1
  Next c
  [j2].Resize(mondico.Count, 1) = Application.Transpose(mondico.items)
End Sub

Avec 2 critères

Sub compteOccurences2critères()
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range("A2", [A65000].End(xlUp))
    temp = c & "-" & c.Offset(, 1)
    mondico(temp) = IIf(mondico.exists(temp), mondico(temp) + 1, 1)
  Next c
  [e2].Resize(mondico.Count, 1) = Application.Transpose(mondico.keys)
  [f2].Resize(mondico.Count, 1) = Application.Transpose(mondico.items)
End Sub

Regroupement des items de chaque code

Pour chaque code (en colonne A), on regroupe sur la même ligne tous les items(colonne B) associés au code,y compris les doublons. Une version MAC (sans Dictionary) est disponible dans Regroupe MAC.

Regroupe
Regroupe MAC
Regroupe sans doublons sur les items
Regroupe Transpose

Sub Regroupe()
  Set d = CreateObject("Scripting.Dictionary")
  Tbl = Range("A2:B" & [a65000].End(xlUp).Row).Value
  For i = LBound(Tbl) To UBound(Tbl)
   d(Tbl(i, 1)) = d(Tbl(i, 1)) & Tbl(i, 2) & "|"
  Next i
  [D2].Resize(d.Count) = Application.Transpose(d.keys)
  [E2].Resize(d.Count) = Application.Transpose(d.items)
  Application.DisplayAlerts = False
  Range("E2").Resize(d.Count).TextToColumns Other:=True, OtherChar:="|"
  Cells.EntireRow.AutoFit
End Sub

ou

Sub Regroupe2()
  Set d = CreateObject("Scripting.Dictionary")
  Tbl = Range("A2:B" & [a65000].End(xlUp).Row).Value
  For i = LBound(Tbl) To UBound(Tbl)
     d(Tbl(i, 1)) = d(Tbl(i, 1)) & Tbl(i, 2) & "|"
  Next i
  lig = 2
  For Each c In d.keys
    Cells(lig, "D") = c
    Tbl2 = Split(d.Item(c), "|")
    Cells(lig, "D").Offset(, 1).Resize(, UBound(Tbl2) + 1) = Application.Transpose(Application.Transpose(Tbl2))
    lig = lig + 1
  Next c
End Sub

ou

Sub regroupe3()
  Set d = CreateObject("Scripting.Dictionary")     ' index position de la clé dans TblD(): 1,2,3,..
  Tbl = Range("A2:B" & [A65000].End(xlUp).Row).Value
  Dim TblD(): ReDim TblD(1 To UBound(Tbl), 1 To 2)
  For i = 1 To UBound(Tbl)
     If Not d.exists(Tbl(i, 1)) Then d(Tbl(i, 1)) = d.Count + 1: TblD(d.Count, 1) = Tbl(i, 1)
     TblD(d(Tbl(i, 1)), 2) = TblD(d(Tbl(i, 1)), 2) & Tbl(i, 2) & "|"
  Next i
  [d2].Resize(d.Count, 2) = TblD
  Application.DisplayAlerts = False
  Range("E2").Resize(d.Count).TextToColumns Other:=True, OtherChar:="|"
End Sub

ou

Sub regroupe4()
  Set d1 = CreateObject("Scripting.Dictionary") '  index position de la clé dans TblD(): 1,2,3,..
  a = Range("A2:B" & [A65000].End(xlUp).Row)
  Dim TblD(): ReDim TblD(1 To UBound(a), 1 To 200)
  Set d2 = CreateObject("Scripting.Dictionary") ' position du dernier item de chaque clé
  For i = LBound(a) To UBound(a)
    If Not d1.exists(a(i, 1)) Then d1(a(i, 1)) = d1.Count + 1 ' index no ligne de la table TblD()
    d2(a(i, 1)) = d2(a(i, 1)) + 1 ' on incrémente la position dernier item de chaque clé
    TblD(d1(a(i, 1)), 1) = a(i, 1)
    TblD(d1(a(i, 1)), d2(a(i, 1)) + 1) = a(i, 2) ' item en ligne/colonne
  Next
  Range("d2").Resize(d1.Count, Application.Max(d2.items) + 1) = TblD
End Sub

ou

Sub Regroupe5()
  Set d1 = CreateObject("Scripting.Dictionary") ' clés et index des nos de ligne te TblD()
  Set d3 = CreateObject("Scripting.Dictionary") ' recherche max items de chaque clé
  a = Range("A2:B" & [A65000].End(xlUp).Row)
  For i = LBound(a) To UBound(a) ' Crée un index des positions des clés
    If Not d1.exists(a(i, 1)) Then d1(a(i, 1)) = d1.Count + 1 ' no ligne clé
    d3(a(i, 1)) = d3(a(i, 1)) + 1
  Next i
  mx = Application.Max(d3.items) ' maxi items
  Dim TblD(): ReDim TblD(1 To d1.Count, 1 To mx + 1)
  Set d2 = CreateObject("Scripting.Dictionary") ' position du dernier item de chaque clé
  For i = LBound(a) To UBound(a)
    d2(a(i, 1)) = d2(a(i, 1)) + 1
    TblD(d1(a(i, 1)), 1) = a(i, 1)
    TblD(d1(a(i, 1)), d2(a(i, 1)) + 1) = a(i, 2) ' item en ligne/colonne
  Next
  Range("d2").Resize(d1.Count, mx + 1) = TblD
End Sub

Autre exemple

Regroupe les codes dans une cellule

Regroupe

Sub Regroupe()
  Set d = CreateObject("Scripting.Dictionary")
  For Each c In Range("b2", [b65000].End(xlUp))
      d(c.Value) = d(c.Value) & c.Offset(0, -1) & " "
  Next c
  [d2].Resize(d.Count) = Application.Transpose(d.keys)
  [e2].Resize(d.Count) = Application.Transpose(d.items)
End Sub

Listes inverses

ListesInverses
ListesInverses2

Sub ListeInverses()
  Set d = CreateObject("Scripting.Dictionary")
  For Each c In [B2:D2].Resize(Application.CountA([a:a]))
    If c.Value <> "" Then d(c.Value) = d(c.Value) & Cells(c.Row, 1) & " "
  Next c
  ligne = 2
  For Each c In d.keys
    Cells(ligne, "g") = c
    a = Split(d.Item(c), " ")
    Cells(ligne, "g").Offset(, 1).Resize(, UBound(a) + 1) = a
    ligne = ligne + 1
  Next c
  [G2].CurrentRegion.Sort Key1:=Range("G2"), Order1:=xlAscending, Header:=xlGuess
End Sub

Autre exemple

On a la liste des communes et codes postaux de chaque département sous forme d'une BD

Depart   Commune                              Codepos
AIN        AMAREINS                               1090
AIN        AMAREINS FRANCHELEINS CES 1090
AIN        AMBERIEU EN BUGEY                1500

On veut la liste des communes de chaque département sur un ligne

AIN      AMAREINS 1090 AMAREINS FRANCHELEINS CES 1090 AMBERIEU EN BUGEY 1500
AISNE  ABBECOURT 2300 ACHERY 2800 ACY 2200
ALLIER ABREST 3200 AGONGES 3210 AINAY LE CHATEAU 3360

Listes Inverses 3

Sub ListeInverses()
   Application.ScreenUpdating = False
   Set d = CreateObject("Scripting.Dictionary")
   Set f1 = Sheets("liste")
   a = f1.Range("a2:c" & f1.[A65000].End(xlUp).Row).Value
   For i = LBound(a) To UBound(a)
      d(a(i, 1)) = d(a(i, 1)) & "|" & a(i, 2) & "|" & a(i, 3)
   Next i
   ligne = 2
   Set f2 = Sheets("result")
   For Each c In d.Keys
      f2.Cells(ligne, "a") = c
      a = Split(d.Item(c), "|")
      f2.Cells(ligne, "a").Offset(, 1).Resize(, UBound(a) + 1) = a
      ligne = ligne + 1
   Next c
End Sub

Nombre de commandes distinctes par vendeur

Sub groupe2()
  Set mondico = CreateObject("Scripting.Dictionary")
  a = Range("b2:b" & [B65000].End(xlUp).Row).Value
  b = Range("a2:b" & [a65000].End(xlUp).Row).Value
  For Each c In a
    mondico(c) = 1
  Next
  [H2].Resize(mondico.Count) = Application.Transpose(mondico.keys)
  For Each v In mondico.keys
    Set mondico2 = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(a)
      If a(i, 1) = v Then mondico2(b(i, 1)) = 1
    Next i
    [I2].Offset(k, 0) = mondico2.Count
    k = k + 1
  Next v
End Sub

ADOGroupBY

Extraction des listes par catégorie

ExtractCaté

Private Sub Worksheet_Activate()
  Set f = Sheets("référence")
  [A2:H10000].ClearContents
  For d = 0 To 6
    Set mondico = CreateObject("Scripting.Dictionary")
    For Each c In f.Range(f.Cells(2, 2 + d), f.Cells(65000, 2 + d).End(xlUp))
      If c = "x" Then mondico(c.Offset(, -1 - d).Value) = 1
    Next c
    Cells(2, 2 + d).Resize(mondico.Count, 1) = Application.Transpose(mondico.keys)
    Range(Cells(2, 2 + d), Cells(1000, 3 + d)).Sort Key1:=Cells(2, 2 + d), Order1:=xlAscending, Header:=xlNo
   Next d
   f.[A2:A10000].Copy [A2]
   [A1:A10000].Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess
End Sub

Comparaison de classeurs (10.000 éléments)

On veut connaitre les éléments de Classeur1.xls qui n'existent pas dans Classeur2.xls

Sub ComparaisonColonne()
  f = 1 'no feuille
  Application.ScreenUpdating = False
  Set MonDico1 = CreateObject("Scripting.Dictionary")
  Set MonDico2 = CreateObject("Scripting.Dictionary")
  Workbooks("classeur1.xls").Activate
  Sheets(f).Activate
  For Each c In Sheets(f).Range("A:D").SpecialCells(xlCellTypeConstants, 23)
     MonDico1(c.Value) = c.Address
  Next
  Workbooks("classeur2.xls").Activate
  Sheets(f).Activate
  For Each c In Sheets(f).Range("A:D").SpecialCells(xlCellTypeConstants, 23)
    MonDico2(c.Value) = ""
  Next
  Workbooks("classeur1.xls").Activate
  For Each e In MonDico1
    Range(MonDico1(e)).Font.Color = IIf(MonDico2.Exists(e), vbBlack, vbRed)
  Next
  Application.ScreenUpdating = True
End Sub

Liste des mots d'un champ

La fonction matricielle ListeMots() extrait tous les mots d'un champ.

ListeMots


Function ListeMots(champ As Range)
  exclus = Array("le", "les", "des", "sur", "elle", "est")
  a = champ
  Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In a
     b = Split(c, " ")
     For Each k In b
        If Len(k) > 2 And Not IsNumeric(k) And IsError(Application.Match(k, exclus, 0)) Then
           mondico.Item(LCase(k)) = LCase(k)
        End If
     Next k
  Next c
  Dim temp()
  ReDim temp(1 To Application.Caller.Rows.Count)
  i = 1
  For Each c In mondico.items
    temp(i) = c
    i = i + 1
  Next
  Call tri(temp, 1, mondico.Count)
  ListeMots = Application.Transpose(temp)
End Function

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

Nos complémentaires

On recherche les nos complémentaires d'une liste de nos.

Complément
Complément3

Sub Mcomplément()
  Set mondico = CreateObject("Scripting.Dictionary")
  Set champ = Range("A2:A1000")
  For i = Application.Min(champ) To Application.Max(champ)
    If IsError(Application.Match(i, champ, 0)) Then mondico(i) = i
  Next i
  [C2].Resize(mondico.Count) = Application.Transpose(mondico.items)
End Sub

Sous forme d'une fonction perso matricielle.

Function complément(champ)
  Set mondico = CreateObject("Scripting.Dictionary")
  For i = Application.Min(champ) To Application.Max(champ)
    If IsError(Application.Match(i, champ, 0)) Then mondico(i) = i
  Next i
  Dim b()
  ReDim b(1 To champ.Count)
  i = 1
  For Each c In mondico.items
    b(i) = c
    i = i + 1
  Next
  complément = Application.Transpose(b)
End Function

Fonction liste sans doublons triée multi-zones

ListeSDTriéeMZ
FonctionSansDoublonsTriéeMultiZones

Function ListeSDTriéeMZ(champ)
  Application.Volatile
  Set mondico = CreateObject("Scripting.Dictionary")
  For i = 1 To champ.Areas.Count ' parcours des zones du champ multi-zones
     For j = 1 To champ.Areas(i).Count ' parcours des éléments d'une zone
       If champ.Areas(i)(j) <> "" And champ.Areas(i)(j) <> "." Then
         temp = champ.Areas(i)(j)
         mondico.Item(temp) = temp ' ajout au dictionnaire (doublons éliminés)
       End If
     Next j
   Next i
   temp = mondico.items 'transfert dictionnaire dans une table temp()
   Call Tri(temp, LBound(temp), UBound(temp)) ' tri optionnel
   Dim d(): ReDim d(Application.Caller.Rows.Count) ' table pour retour
   For i = LBound(temp) To UBound(temp): d(i) = temp(i): Next i
   ListeSDTriéeMZ = Application.Transpose(d)
End Function

Sub Tri(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
      tmp = a(g): a(g) = a(d): a(d) = tmp
      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

Suppression de doublons multi-feuilles

SupDoublonsMF2Critères
SupDoublonsMFUnCritère

Sub ListeSansDoublons()
  Set mondico = CreateObject("Scripting.Dictionary")
    For s = 1 To Sheets.Count - 1
      For Each c In Range(Sheets(s).[a2], Sheets(s).[a65000].End(xlUp))
         tmp = c & "*" & c.Offset(, 2)
         mondico(tmp) = tmp
      Next c
   Next s
   i = 2
   For Each c In mondico
    a = Split(c, "*")
    Sheets("synthèse").Cells(i, 1) = a(0)
    Sheets("synthèse").Cells(i, 2) = "'" & (a(1))
    i = i + 1
  Next c
End Sub

Sub ColoriageDoublons()
  Set mondico = CreateObject("Scripting.Dictionary")
  For s = 1 To Sheets.Count - 1
     [A:A].Interior.ColorIndex = xlNone
     For Each c In Range(Sheets(s).[a2], Sheets(s).[a65000].End(xlUp))
        tmp = c & "*" & c.Offset(, 2)
        mondico.Item(tmp) = mondico.Item(tmp) + 1
    Next c
  Next s
  For s = 1 To Sheets.Count - 1
    For Each c In Range(Sheets(s).[a2], Sheets(s).[a65000].End(xlUp))
       tmp = c & "*" & c.Offset(, 2)
       If mondico.Item(tmp) > 1 Then c.Interior.ColorIndex = 3
     Next c
   Next s
End Sub

Concaténation d'un champ

On a dans un champ une liste avec des cellules vides:

aa
bb
cc
dd

On veut obtenir aa,bb,cc,dd

=ConcatChamp(A2:A100;",")

Function concatChamp(champ As Range, sep)
  Set mondico = CreateObject("Scripting.Dictionary")
  For i = 1 To champ.Count
    If Not IsEmpty(champ(i)) And Not champ(i) = 0 Then mondico(champ(i).Value) = ""
  Next i
  concatChamp = Join(mondico.keys, sep)
End Function

Pour obtenir aa,bb,cc et dd

Function concatChamp2(champ As Range, sep)
  Set mondico = CreateObject("Scripting.Dictionary")
  For i = 1 To champ.Count
    If Not IsEmpty(champ(i)) And Not champ(i) = 0 Then mondico(champ(i)) = 1
  Next i
  temp = Join(mondico.keys, sep)
  p = InStrRev(temp, ",")
  concatChamp2 = Left(temp, p - 1) & Replace(Mid(temp, p), ",", " et ")
End Function

Concat

Mise à jour d'une liste existante

En colonne A de la feuille Extraction sans doublons, nous avons la liste des numéros appelés dans l'année.
Périodiquement, on ajoute les nouveaux numéros appelés de la feuille Appels du mois . Les nouveaux numéros sont ajoutés à la fin de la liste.

MajListeExistante

Sub MajTph()
  Set f1 = Sheets("appels du mois")
  Set f2 = Sheets("extraction sans doublons")
  Set d1 = CreateObject("Scripting.Dictionary")
  For Each c In f2.[A2:A1000]
    If c.Text <> "" Then d1(c.Text) = ""
  Next c
  Set d2 = CreateObject("Scripting.Dictionary")
  For Each c In f1.[A3:L35]
    If c.Text <> "" Then
      If Not d1.exists(c.Text) Then d2(c.Text) = ""
    End If
  Next c
  If d2.Count > 0 Then f2.[a65000].End(xlUp).Offset(1).Resize(d2.Count, 1) = Application.Transpose(d2.keys)
End Sub

Recherche rapide dans une colonne d'un tableau 2D

Une recherche d'une valeur dans une colonne d'un tableau 2D de 20.000 lignes est égale à 0,008 sec.
Pour accélérer la recherche d'une clé dans une colonne d'un tableau 2D, on peut l'indexer par un Dictionnaire (idée de Pierre Jean). On obtient un temps de 0,00003 sec (rapport 200).

IndexationTableau2DDico

Sub RechercheDico()
  '---- Création de l'index
  Set mondico = CreateObject("scripting.dictionary")
  a = [A1:C20000]
  For i = 1 To 20000
     mondico(a(i, 1)) = i
  Next i
  '--- Recherche
  clé = "Nom15000"
  ligne = mondico(clé)
  val1 = a(ligne, 2)
  val2 = a(ligne, 3)
  MsgBox val1 & " " & val2
End Sub

ou

Sub RechercheDico2()
  Set mondico = CreateObject("scripting.dictionary")
  a = [A1:C20000]
  For i = 1 To 20000
     mondico(a(i, 1)) = i
  Next i
  clé = "Nom15000"
  ligne = mondico(clé)
  b = Application.Index(a, ligne)
  MsgBox b(1) & " " & b(2) & " " & b(3)
End Sub

Un dictionnaire n'accepte que des clés uniques.
Si la colonne ne contient pas que des clés uniques (la ville par exemple en colonne D contient plusieurs fois Paris), on fabrique alors des pseudos clés.

Sub RechercheDicoVille()
  '--- construction index ville (plusieurs fois la même ville)
  Set mondico = CreateObject("scripting.dictionary")
  a = [A1:D20000]
  For i = 1 To 20000
    CléBase = a(i, 4)
    Clé = CléBase
    indice = 1
    Do While mondico.exists(Clé)
       Clé = CléBase & indice
       indice = indice + 1
    Loop
    mondico(Clé) = i
  Next i
  '--recherche (0,03 sec pour 1.000 recherches)
  CléBase = "Paris"
  Clé = CléBase
  indice = 1
  Do While mondico.exists(Clé)
    ligne = mondico(Clé)
    val1 = a(ligne, 1)
    val2 = a(ligne, 4)
    MsgBox val1 & " " & val2
    Clé = CléBase & indice
    indice = indice + 1
  Loop
End Sub

Meilleure note

Donne le produit qui contient le plus de mots par rapport à la demande client.

Meilleure Note
Meilleure Note2

Recherche d'une valeur proche

Nous recherchons Entr. de recup. dans Entreprise de récupération

Proche
Proche3
ProcheMult
ProcheMult2
Proche Société

Synthèse de 2 tableaux

SynthèsexTableaux

Suppression doublons colonne

Suppression doublons en colonnes

Indexation d'un tableau 2D avec Dictionary pour augmenter la vitesse

Cette fonction perso matricielle calcule la somme de plusieurs onglets suivant 2 critères.
-Les listes des codes et des villes sont obtenues et triées automatiquement par la fonction.
-Cette fonction est rapide: grâce à Dictionary, la recherche de la ligne et de la colonne du tableau de cumul Tbl() se fait très rapidement.

Fonction Somme3D 2 critères

-Sélectionner A1:E10
=S3DTriée(1;3; "a2:a20";"b2:b20"; "c2:c20")
-valider avec maj+ctrl+entrée

Function S3DTriée(début, fin, critLigne, CritColonne, ChampSomme)
  Application.Volatile
  Dim Tbl()
  ReDim Tbl(0 To Application.Caller.Rows.Count, 0 To Application.Caller.Columns.Count)
  Set dLig = CreateObject("Scripting.Dictionary")
  Set dCol = CreateObject("Scripting.Dictionary")
  For s = début To fin
    a = Sheets(s).Range(critLigne).Value
    b = Sheets(s).Range(CritColonne).Value
    For i = LBound(a) To UBound(a)
      If a(i, 1) <> "" Then If Not dLig.exists(a(i, 1)) Then dLig(a(i, 1)) = ""
      If b(i, 1) <> "" Then If Not dCol.exists(b(i, 1)) Then dCol(b(i, 1)) = ""
    Next i
  Next s
  crit1 = dLig.keys: Call Tri(crit1, LBound(crit1), UBound(crit1))
  dLig.RemoveAll: For i = 0 To UBound(crit1): dLig(crit1(i)) = i + 1: Next
  lig = 1: For Each c In dLig.keys: Tbl(lig, 0) = c: lig = lig + 1: Next c
  crit1 = dCol.keys: Call Tri(crit1, LBound(crit1), UBound(crit1))
  dCol.RemoveAll: For i = 0 To UBound(crit1): dCol(crit1(i)) = i + 1: Next
  k = 1: For Each c In dCol.keys: Tbl(0, k) = c: k = k + 1: Next c
  For s = début To fin
    idxLig = Sheets(s).Range(critLigne).Value
    idxCol = Sheets(s).Range(CritColonne).Value
    a = Sheets(s).Range(ChampSomme).Value
    For lig = LBound(a) To UBound(a)
      cléLig = CStr(idxLig(lig, 1)): clécol = idxCol(lig, 1)
      If cléLig <> "" And clécol <> "" Then
        ligtbl = dLig(cléLig): coltbl = dCol(clécol)
        Tbl(ligtbl, coltbl) = Tbl(ligtbl, coltbl) + a(lig, 1)
      End If
    Next lig
  Next s
  S3DTriée = Tbl
End Function

Remplacer par multiple

On doit remplacer les contenus de cellules mal orthographiés.
La corrrespondance Mauvaise orthographe -> Bonne orthographe des mots à remplacer est dans un dictionnaire.La recherche dans ce dictionnaire se fait très rapidement.

Remplacer par

Sub essai()
  Application.ScreenUpdating = False
  Set d = CreateObject("Scripting.Dictionary")
  a = [H2:I2].Resize([h65000].End(xlUp).Row)
  For i = LBound(a) To UBound(a)
     d(a(i, 1)) = a(i, 2)
  Next i
  For Each c In Selection
     If d.exists(c.Value) Then c.Value = d(c.Value)
  Next
End Sub

Recherche rapide de mots dans des phrases

On recherche dans des phrases en colonne A la présence de mots en colonne C.

DicoPhraseMots

Sub rechercheMotEntiersDansPhrase()
  Application.ScreenUpdating = False
  Set d = CreateObject("Scripting.Dictionary")
  For Each c In Range("D2:D" & [D65000].End(xlUp).Row): d(c.Value) = "": Next c
    Tbl = Range("a2:a" & [A65000].End(xlUp).Row).Value
     ReDim TblResult(1 To UBound(Tbl))
     For i = LBound(Tbl) To UBound(Tbl)
        b = Split(Replace(Tbl(i, 1), "'", " "), " ")
        For j = LBound(b) To UBound(b)
          If d.Exists(b(j)) Then TblResult(i) = TblResult(i) & " " & b(j)
        Next j
     Next i
     [b2].Resize(UBound(Tbl)) = Application.Transpose(TblResult)
End Sub

Indexation d'une BD pour une recherche rapide de mots

Sur cette version, nous recherchons des mots dans une BD de 30.000 phrases.
Un index de 3000 mots vers les phrases est crée à l'aide d'un dictionnaire et sauvegardé dans le classeur.Le temps de recherche d'un mot est <0,01 sec.

Recherche rapide phrases qui contiennent un mot
Recherche rapide phrases qui contiennent 2 mots

Ci dessous, pour une recherche de rue dans une liste de 330.000 adresses, le temps de recherche est inférieur à 0,1 sec. La recherche dans le combobox est intuitive.

-Avec les Arrays ou le Filtre élaboré, le temps de recherche est proportionnel au nombre de lignes de la BD.
-Avec l'indexation des mots (colonnes F & G) , le temps de recherche est très faible et augmente très peu avec le nombre de lignes de la BD. Ce qui prend du temps, c'est la création de l'index( à faire une seule fois). Dans le fichier joint, elle est déjà faite (Colonnes F et G). Dans le fichier joint (330.000 lignes) , on peut comparer les temps des différentes méthodes (onglet tests)

Recherche rapide d'une rue dans une adresse
Recherche rapide d'une rue dans une adresse 2
Recherche Multi mots

Option Compare Text
Dim bd(), choix1(), Choix1Col()
Private Sub UserForm_Initialize()
  Set d = CreateObject("Scripting.Dictionary")
  bd = Range("f2:g" & [f65000].End(xlUp).Row).Value
  For i = 1 To UBound(bd)
     d(bd(i, 1)) = bd(i, 2)
  Next i
  choix1 = bd
  Me.ComboBox1.List = bd
End Sub

Private Sub ComboBox1_Change()
   If Me.ComboBox1.ListIndex = -1 Then
      Dim b()
      tmp = Me.ComboBox1 & "*"
      n = 0
      For i = LBound(choix1) To UBound(choix1)
        If UCase(choix1(i, 1)) Like tmp Then
           n = n + 1: ReDim Preserve b(1 To 2, 1 To n)
           b(1, n) = choix1(i, 1): b(2, n) = choix1(i, 2)
       End If
     Next i
     If n > 0 Then Me.ComboBox1.Column = b: Me.ComboBox1.DropDown
   End If
  End If
End Sub

Private Sub ComboBox1_Click()
  Me.ListBox1.Clear
  If Me.ComboBox1.Column(1) <> "" Then
    b = Split(Me.ComboBox1.Column(1), "|")
    n = 0
    Dim bb()
    For Each c In b
      If c <> "" Then
         n = n + 1: ReDim Preserve bb(1 To 2, 1 To n)
         bb(1, n) = Cells(Val(c), "A"): bb(2, n) = c
       End If
    Next c
    Me.ListBox1.Column = bb
    Me.TextBox1 = Me.ListBox1.ListCount
  End If
End Sub

Recherche Array classique

Sub RechercheArrayClassique()
  t = Timer
  mot = "*maupassant*"
  Tbl = Range("a2:a" & [a1000000].End(xlUp).Row)
  n = 0: Dim b()
  For i = 1 To UBound(Tbl)
    If Tbl(i, 1) Like mot Then
      n = n + 1: ReDim Preserve b(1 To n)
      b(n) = Tbl(i, 1)
    End If
  Next i
  [C2].Resize(n) = Application.Transpose(b)
  MsgBox Timer - t     ' 1,4 sec pour 330.000 lignes
  MsgBox n
End Sub

Recherche Array avec Filter()

Sub RechercheFilter()
  t = Timer
  mot = "maupassant"
  Tbl = Range("a2:a" & [a1000000].End(xlUp).Row)
  n = UBound(Tbl)
  Dim a(): ReDim a(1 To n)
  For i = 1 To n
    a(i) = Tbl(i, 1)
  Next i
  b = Filter(a, mot, True, vbTextCompare)
  [C2].Resize(n) = Application.Transpose(b)
  MsgBox Timer - t    ' 1,6 sec pour 330.000 lignes
End Sub

Filtre avancé

Sub FiltreAvancé()
  tt = Timer
  Set f = Sheets("bd")
  f.Range("A1:B333515").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
     Range("h1:h2"), CopyToRange:=Range("j1:k1"), Unique:=False
  MsgBox Timer - tt  ' 2,5 sec pour 330.000 lignes
End Sub

Fonction FrequenceTexte

Donne la fréquence de texte dans une liste de cellules contenant du texte.

Fonction_Frequence_Texte
Fonction_Frequence_Texte_Mac
Fonction Frequence Texte Classement
Fonction Frequence Mots
Fonction Frequence Texte critère
Fonction Frequence Texte Groupe

Function FrequenceTexte(champ As Range)
   Set d1 = CreateObject("Scripting.Dictionary")
   d1.CompareMode = vbTextCompare
   temp = champ
   For i = LBound(temp) To UBound(temp)
     c = temp(i, 1)
     If c <> "" Then d1(c) = d1(c) + 1
   Next i
   Dim b()
   ReDim b(1 To d1.Count, 1 To 2)
   i = 1
   For Each c In d1.keys
     b(i, 1) = c: b(i, 2) = d1(c)
   i = i + 1
   Next
   Call tri(b, 1, d1.Count)
   FrequenceTexte = b
End Function

Nombre d'occurences des doublons

On veut classer les doublons par ordre du nombre d'occurences.

Occurences doublons

Sub DoublonsOccurence()
  a = Range("A2:H" & [A65000].End(xlUp).Row).Value
  Set d = CreateObject("scripting.dictionary")
  For i = LBound(a) To UBound(a)
     d(CStr(a(i, 2))) = d(CStr(a(i, 2))) + 1
     a(i, UBound(a, 2)) = d(CStr(a(i, 2)))
  Next i
  Set f = Sheets("result")
  f.Cells.Clear: [A1:H1].Copy f.[A1]
  f.[a2].Resize(UBound(a), UBound(a, 2)) = a
  f.[a2].Sort key1:=f.[h2], key2:=f.[b2], Header:=yes
  For i = f.[A65000].End(xlUp).Row To 3 Step -1
     If f.Cells(i, 8) <> f.Cells(i - 1, 8) Then f.Rows(i).Insert
  Next i
  Set Rng = f.Range("A2:H" & f.[A65000].End(xlUp).Row).SpecialCells(xlCellTypeConstants)
  For i = 1 To Rng.Areas.Count
    Rng.Areas(i).BorderAround Weight:=xlMedium
  Next i
End Sub

Fonction communs à 3 listes

-sélectionner W2:Z2
=communs(B2:H2;J2:O2;Q2:U2)
Valider avec maj+ctlrl +entrée

Fonction Communs 3 listes

Avantages d'une fonction UDF
-Utilisable comme une fonction standard par une personne qui ne connait pas VBA
-Pas besoin de modifier le code si on déplace les données
-Réutilisable

Function Communs(tab1, tab2, tab3)
  Dim temp()
  Set d1 = CreateObject("Scripting.Dictionary")
  For Each c In tab1
    If Not d1.Exists(c.Value) Then d1(c.Value) = ""
  Next c
  Set d2 = CreateObject("Scripting.Dictionary")
  For Each c In tab2
     If c.Value <> "" And d1.Exists(c.Value) Then
        If Not d2.Exists(c.Value) Then d2(c.Value) = ""
     End If
   Next c
   Set d3 = CreateObject("Scripting.Dictionary")
   For Each c In tab3
      If c <> "" And d2.Exists(c.Value) Then
         If Not d3.Exists(c.Value) Then d3(c.Value) = ""
      End If
    Next c
    n = Application.Caller.Columns.Count
    If n < d3.Count Then
       Communs = "Selection insuffisante"
    Else
      ReDim temp(1 To n)
      i = 1
     For Each c In d3.keys
        temp(i) = c
        i = i + 1
     Next
     Communs = temp
   End If
End Function

Extraction de lignes d'un Array

Sur cet exemple, nous extrayons les lignes d'un Array pour chaque code.

Extraction Array
Extraction Array Onglets

-Nous créons un dictionnaire d des codes. Pour chaque code, nous stockons les nos de lignes du tableau(Array)

Set d = CreateObject("scripting.dictionary")
For i = 1 To UBound(bd): d(bd(i, 2)) = d(bd(i, 2)) & i & ",": Next ' Dictionnaire

-Pour chaque code, nous extrayons les lignes du tableau bd() dans un tableau a()

For Each k In d.keys
   a = Application.Index(bd, Application.Transpose(Split(d.Item(k), ",")), Array(1, 3)) 'Extract Array
   f.Cells(ligne + 1, "g").Resize(UBound(a) - 1, UBound(a, 2)) = a
   ligne = ligne + UBound(a) + 1
Next k

Liste des items pour chaque code

Pour chaque code, on veut la liste des items

Code     Item
1000003 AC-026
1000003 AC-051

1000004 AC-027
1000004 AC-052
1000004 AC-053

  =>

Code       Items
1000003   AC-026,AC-051
1000004   AC-027,AC-052,AC-053

Sub ListeItemsi()
  Set Rng = Range("A2:A" & [A65000].End(xlUp).Row)
  Set d = CreateObject("Scripting.Dictionary")
  For Each c In Rng
     If d.exists(c.Value) Then d(c.Value) = d(c.Value) & "," & c.Offset(, 1).Value Else d(c.Value) = c.Offset(, 1).Value
   Next
   [E2].Resize(d.Count) = Application.Transpose(d.keys)
   [f2].Resize(d.Count) = Application.Transpose(d.items)
End Sub

Fonction perso NBSIMAT(champ) plus rapide que NB.SI()

Dans la colonne A, on a une liste de noms (10.000 noms). On veut compter en colonne B le nombre de fois que ces noms apparaissent avec NB.SI(A$2:A$10000;A2).

- En recopiant cette formule 10.000 fois, le temps de calcul est de 3 secondes
-Avec une fonction perso NBSIMAT(A2:A10000), le temps de calcul n'est pas visuellement mesurable

NBSIMAT

Function NBSIMAT(champ)
  t = champ
  Set d1 = CreateObject("Scripting.Dictionary")
  For Each c In t
     d1(c) = d1(c) + 1
  Next c
  Dim t2(): ReDim t2(1 To UBound(t))
  For i = 1 To UBound(t)
     t2(i) = d1(t(i, 1))
  Next i
  NBSIMAT = Application.Transpose(t2)
End Function

La fonction perso =FiltreCol(champColBD;TitreCol) donne l’expression d'un filtre automatique pour la colonne

Filtre Auto Fonctions Perso

Function FiltreCol(Champ As Range, TitreChamp As Range)
  Application.Volatile
  If Not ChampActif(TitreChamp) Then FiltreCol = "": Exit Function
  Set d = CreateObject("scripting.dictionary")
  d.CompareMode = vbTextCompare
  For Each c In Champ
     If Not c.EntireRow.Hidden And c.Value <> "" Then d(c.Value) = c.Value
  Next c
  a = d.items
  If IsDate(Champ(1)) Then
    If d.Count = 1 Then
       FiltreCol = TitreChamp & ":" & Format(a(0), "dd/mm/yyyy")
    Else
       mini = a(0): maxi = a(0)
       For i = LBound(a) To UBound(a)
         If a(i) < mini Then mini = a(i)
         If a(i) > maxi Then maxi = a(i)
       Next i
       FiltreCol = TitreChamp & ":" & "> " & mini & " et < " & maxi
    End If
   Else
     FiltreCol = TitreChamp & ":" & Join(a, ",")
   End If
End Function

Fonction nombre valeurs uniques avec 1 ou 2 critères

Nb Valeurs Uniques 2 critères



 

 


 

 

 

 

 

 

 

 

 

 

Exemples

Dictionary
Comparaison2BDRapide