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
Dictionnaire indicé
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
Totalisation par groupe
Maj Stock
Sous total de tableau 2D avec indexation dictionnaire
Consolidation de plusieurs tableaux
Consolidation de tableaux 2D
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
Liste des valeurs uniques 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
Synthèses 3D
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
Compte noms champ
Rapport
Dictionary pour remplacer sommprod
Maj colonne avec Dictionary au lieu de VLookUp

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

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

Tableau de dictionnaires

Tableau de dictionnaires

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

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
FormLSDCollectionTriéMAC
Fonction Sans Doublons
Fonction Sans Doublons Array
Fonction Sans Doublons triés
Fonction Sans Doublons triés MAC
Fonction Sans Doublons Trié Multi zones
Fonction Sans Doublons Trié Multi zones 3

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:

Form LSD Collection MAC
Form LSD Collection MAC 2
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
Fonction Sans Doublons 2 colonnes

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
  Set d = CreateObject("Scripting.Dictionary")
  n = 0
  Dim b()
  For i = LBound(a) To UBound(a)
    tmp = a(i, 1) & a(i, 2)
    If Not d.exists(tmp) Then
      d(tmp) = ""
      n = n + 1
      ReDim Preserve b(1 To 2, 1 To n)
      b(1, n) = a(i, 1): b(2, n) = a(i, 2)
     End If
   Next i
   Me.ComboBox1.Column = b
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
Dico structure

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

Dictionnaire indicé

Sur cet exemple, nous extrayons les éléments distincts de chaque colonne d'une bd ainsi que le nombre d'apparitions de chque élément.

Sans doublons colonnes BD

Sub DicoIndice()
  Set f = Sheets("bd")
  Tbl = f.[A1].CurrentRegion.Value
  NbCol = UBound(Tbl, 2)
  NbLig = UBound(Tbl)
  Dim d(): ReDim d(1 To NbCol)
  Dim Titre(): ReDim Titre(1 To NbCol)
  For col = 1 To NbCol
    Set d(col) = CreateObject("scripting.dictionary")
    d(col).CompareMode = vbTextCompare ' ignore la casse
  Next col
  For col = 1 To NbCol ' remplissage dictionnaire
     Titre(col) = Tbl(1, col)
     For lig = 2 To NbLig
        tmp = Tbl(lig, col)
        d(col)(tmp) = d(col)(tmp) + 1
     Next lig
  Next col
  Set f2 = Sheets("result") ' affichage résultat
  For col = 1 To NbCol
    Set Rng = f2.Cells(2, (col - 1) * 2 + 1).Resize(d(col).Count)
    f2.[A1].Offset(, (col - 1) * 2) = Titre(col)
    Rng.Value = Application.Transpose(d(col).keys)
    Rng.Offset(, 1) = Application.Transpose(d(col).items)
    Rng.Resize(, 2).Sort key1:=Rng(1).Offset(, 1), Order1:=xlDescending
  Next col
  f2.[A1].CurrentRegion.Columns.AutoFit
  f2.Select
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
Liste sans doublons Fonction

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
Fonction Compte MAC

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

Totalisation par groupe

Totalisation par groupe
Totalisation par groupe 2
Totalisation 2 critères 1 colonne

Sub Recap()
  Set f = Sheets("BD"): Set result = f.Range("D2")
  Set Dico = CreateObject("Scripting.Dictionary")
  TblBD = f.Range("A2:B" & f.[A65000].End(xlUp).Row)
  For i = 1 To UBound(TblBD): Dico(TblBD(i, 1)) = Dico(TblBD(i, 1)) + TblBD(i, 2): Next i
  result.CurrentRegion.Offset(1).ClearContents
  result.Resize(Dico.Count, 1) = Application.Transpose(Dico.Keys)
  result.Offset(, 1).Resize(Dico.Count, 1) = Application.Transpose(Dico.Items)
  result.CurrentRegion.Sort key1:=result.Offset(1, 1), Order1:=xlDescending, Header:=xlYes
  result.Offset(Dico.Count, 1) = Application.Sum(Dico.Items)
End Sub

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

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 TblE() n'est pas trié:

Sous Total 2 col Num
Sous Total 2 col Num MAC
Sous Total 2 col Num Total Colonnes
Sous Total 2 col Texte

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

Sub SousTotalNonTrié()
  Set d = CreateObject("Scripting.Dictionary")
  TblE = Range("A2:C" & [a65000].End(xlUp).Row)                           ' Table entrée
  Dim TblS(): ReDim TblS(1 To UBound(TblE), 1 To UBound(TblE, 2)) ' Table sortie
  For i = LBound(TblE) To UBound(TblE)
    If d.exists(TblE(i, 1)) Then
      lig = d(TblE(i, 1))            ' Récupération index TblS()
   Else
     d(TblE(i, 1)) = d.Count + 1: lig = d.Count: TblS(lig, 1) = TblE(i, 1)
   End If
   For c = 2 To UBound(TblE, 2): TblS(lig, c) = TblS(lig, c) + TblE(i, c): Next c   ' Totalisation numérique
  Next i
[E2].Resize(d.Count, UBound(TblS, 2)) = TblS
End Sub

ou

Sub SousTotalNonTrié2()
  Set d = CreateObject("Scripting.Dictionary")
  TblE = Range("A2:C" & [a65000].End(xlUp).Row)                            ' Table entrée
  Dim TblS(): ReDim TblS(1 To UBound(TblE), 1 To UBound(TblE, 2))  ' Table sortie
  maxi = 0
  For i = LBound(TblE) To UBound(TblE)
    If d.exists(TblE(i, 1)) Then
       p = d(TblE(i, 1))                             ' Récupération index TblS()
       TblS(p, 2) = TblS(p, 2) + TblE(i, 2)
       TblS(p, 3) = TblS(p, 3) + TblE(i, 3)
    Else
       maxi = maxi + 1
       d(TblE(i, 1)) = maxi
       TblS(maxi, 1) = TblE(i, 1)
       TblS(maxi, 2) = TblE(i, 2)
       TblS(maxi, 3) = TblE(i, 3)
    End If
  Next i
  [E2].Resize(d.Count, UBound(TblS, 2)) = TblS
End Sub

b/Si la table TblE() est triée (fonctionne sur PC & MAC)

Cette méthode est aussi rapide que l'utilisation du dictionnaire. Elle peut être utilisée pour le MAC qui ne dispose pas du dictionnaire.
Pour 20.000 lignes (0,07 sec -0,03 sec si déjà trié/ Dictionary: 0,05 sec/ Collection: 0,11 sec)

Sous Total 2 col triée

Sub SousTotalTablo2col()
  [A1].CurrentRegion.Sort , key1:=[A2], Header:=xlYes
  TblE = Range("A2:D" & [a65500].End(xlUp).Row)                             ' Table entrée
  Dim TblS(): ReDim TblS(1 To UBound(TblE), 1 To UBound(TblE, 2))   ' Table sortie
  i = 1: n = 0
  Do While i <= UBound(TblE)
    n = n + 1
    clé = TblE(i, 1)
    For c = 1 To 2: TblS(n, c) = TblE(i, c): Next c
    Do While TblE(i, 1) = clé
       For c = 3 To 4: TblS(n, c) = TblS(n, c) + TblE(i, c): Next c
       i = i + 1: If i > UBound(TblE) Then Exit Do
    Loop
  Loop
  [J2].Resize(n, UBound(TblS, 2)) = TblS
End Sub

Avec l'objet Collection (fonctionne sur PC & MAC)

Sub SousTotalCollection()
  Dim Collec1 As New Collection
  TblE = Range("A2:D" & [a65000].End(xlUp).Row)                           ' Table entrée
  Dim TblS(): ReDim TblS(1 To UBound(TblE), 1 To UBound(TblE, 2)) " Table sortie
  For i = LBound(TblE) To UBound(TblE)
    clé = TblE(i, 1)
    On Error Resume Next
    Collec1.Add Item:=Collec1.Count + 1, Key:=clé
    If Err > 0 Then
       lig = Collec1(clé)
    Else
       lig = Collec1.Count: TblS(lig, 1) = TblE(i, 1): TblS(lig, 2) = TblE(i, 2)
    End If 
    For c = 3 To UBound(TblE, 2): TblS(lig, c) = TblS(lig, c) + TblE(i, c): Next c   ' Totalisation colonnes 3 & 4
  Next i
  [J2].Resize(n, UBound(TblS, 2)) = TblS
End Sub

Critère multi-colonnes

La clé de regroupement est la concaténation du nom et du prénom.

clé = TblE(i, 1) & "|" & TblE(i, 2)

Sous Total 2 col critère multi-colonnes

Sub SousTotalNonTrié()
  Set d = CreateObject("Scripting.Dictionary")
  TblE = Range("A2:D" & [a65000].End(xlUp).Row)                           ' Table entrée
  Dim TblS(): ReDim TblS(1 To UBound(TblE), 1 To UBound(TblE, 2)) ' Table sortie
  For i = LBound(TblE) To UBound(TblE)
    clé = TblE(i, 1) & "|" & TblE(i, 2)    ' Clé multi-colonnes
   If d.exists(clé) Then
     lig = d(clé)             ' Récupération index TblS()
   Else
     d(clé) = d.Count + 1: lig = d.Count: TblS(lig, 1) = TblE(i, 1): TblS(lig, 2) = TblE(i, 2)   ' Nouvelle clé
   End If
   For c = 3 To UBound(TblE, 2): TblS(lig, c) = TblS(lig, c) + TblE(i, c): Next c ' Totalisation colonnes numériques
  Next i
 [F2].Resize(d.Count, UBound(TblS, 2)) = TblS
End Sub

On peut obtenir obtenir ces résulats avec des fonctions persos (réutilisables) par des utilsateurs ne connaissant pas VBA.

Fonction sous-total 2 critères

Sous-total avec plusieurs colonnes

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

Sub SousTotalPLusieursColonnes()
  Set f = Sheets("données")
  Set Result = f.Range("J1")      ' Adresse résultat
  TblBD = f.Range("A1:E" & f.[A65000].End(xlUp).Row) ' Array pour rapidité
  Ncol = UBound(TblBD, 2)
  Set d = CreateObject("Scripting.Dictionary")
  Dim TblS(): ReDim TblS(1 To UBound(TblBD), 1 To Ncol)
  Dim TblTotCol(): ReDim TblTotCol(1 To Ncol)
  Dim TblTotLig(): ReDim TblTotLig(1 To 1000)
  For i = 2 To UBound(TblBD)
    clé = TblBD(i, 1)
    If Not d.exists(clé) Then d(clé) = d.Count + 1: lig = d(clé) Else lig = d(clé) ' gestion index
      For k = 2 To Ncol
        TblS(lig, k) = TblS(lig, k) + TblBD(i, k)
        TblTotCol(k) = TblTotCol(k) + TblBD(i, k) ' total colonne
        TblTotLig(lig) = TblTotLig(lig) + TblBD(i, k) ' total ligne
      Next k
   Next i
   Result.Offset(1).Resize(d.Count + 1, Ncol) = TblS
   Result.Offset(1).Resize(d.Count, 1) = Application.Transpose(d.keys)         ' titres lignes
   Result.Offset(1, Ncol).Resize(d.Count) = Application.Transpose(TblTotLig) ' totaux lignes
   Result.Resize(1, Ncol) = Application.Index(TblBD, 1)    ' titres colonnes
   Result.Offset(d.Count + 1).Resize(, Ncol) = TblTotCol   ' totaux colonnes
   Result.Offset(1).Resize(d.Count, Ncol + 2).Sort key1:=Result.Offset(1), Order1:=xlAscending, Header:=xlNo
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 T1() n'est pas triée par partNumber. La table T2() est indexée par le dictionnaire pour permettre un accès plus rapide à chaque ligne de la table T2().

Sous Total Tableau 2D
Sous Total Tableau 2D 2

Sub SousTotalNonTrié()
  Set d = CreateObject("Scripting.Dictionary")
  T1 = Range("A2:D" & [a65000].End(xlUp).Row)
  Dim T2(): ReDim T2(1 To UBound(T1), 1 To UBound(T1, 2))
  For i = LBound(T1) To UBound(T1)
    If d.exists(T1(i, 2)) Then p = d(T1(i, 2)) Else d(T1(i, 2)) = d.Count + 1: p = d.Count
    T2(p, 1) = T2(p, 1) + T1(i, 1) ' totalisation colonne Qte
    For k = 2 To 4: T2(p, k) = T1(i, k): Next k ' copie des autres colonnes
  Next i
  [H2].Resize(d.Count, UBound(T2, 2)) = T2
  [A1:D1].Copy [H1]
End Sub

Regroupement dans un Array() avec critère multi-colonnes (élimnination des doublons)

Regroupement

Sub Regroupement()
  Set d = CreateObject("Scripting.Dictionary")
  TblE = Range("A2:L13")                                          ' Array entrée
  Dim TblS(): ReDim TblS(1 To UBound(TblE), 1 To 4)  ' Array sortie
  For i = LBound(TblE) To UBound(TblE)
    clé = TblE(i, 3) & "|" & TblE(i, 4) ' clé de regroupement
    If Not d.exists(clé) Then
      d(clé) = "": lig = d.Count: TblS(lig, 1) = TblE(i, 3): TblS(lig, 2) = TblE(i, 4) ' Nouvelle clé
      For c = 3 To UBound(TblS, 2): TblS(lig, c) = TblE(i, c + 4): Next c   ' recopie des autres colonnes
    End If
  Next i
  [C17].Resize(d.Count, UBound(TblS, 2)) = TblS
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

Consolidation de tableaux 2D

Consolide tableaux 2D

Option Compare Text
Dim d1, d2, TblE(), Tstat(), TblTotLig(), TblTotCol()
Sub ConsolideTab2D()
  Set d1 = CreateObject("Scripting.Dictionary") ' lignes
  d1.CompareMode = vbTextCompare
  Set d2 = CreateObject("Scripting.Dictionary") ' colonnes
  d2.CompareMode = vbTextCompare
  ReDim Tstat(1 To 100, 1 To 100): ReDim TblTotLig(1 To 100): ReDim TblTotCol(1 To 100)
  TblE = Sheets("BD1").Range("C1").CurrentRegion.Value
  Consolide
  TblE = Sheets("BD2").Range("C1").CurrentRegion.Value
  Consolide
  Set Result = Range("a1")
  Result.Offset(1, 1).Resize(d1.Count, d2.Count) = Tstat
  Result.Offset(1).Resize(d1.Count) = Application.Transpose(d1.keys)  ' titres lignes
  Result.Offset(, 1).Resize(, d2.Count) = d2.keys                                ' titres colonnes
  Result.Offset(1).Offset(d1.Count, 1).Resize(, d2.Count) = TblTotCol   ' totaux colonnes
  Result.Offset(1, 1).Offset(, d2.Count).Resize(d1.Count) = Application.Transpose(TblTotLig) ' totaux lignes
  Result.Offset(d1.Count + 1) = "Total "
  Result.Offset(, d2.Count + 1) = "Total"
  '---tri lignes et colonnes
  Set Rng = Result.CurrentRegion
    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

Sub Consolide()
  For i = 2 To UBound(TblE)
  clé = TblE(i, 1) & " " & TblE(i, 2)
  If d1.exists(clé) Then lig = d1(clé) Else d1(clé) = d1.Count + 1: lig = d1.Count    ' gestion index
  For c = 3 To UBound(TblE, 2)
    If d2.exists(TblE(1, c)) Then col = d2(TblE(1, c)) Else d2(TblE(1, c)) = d2.Count + 1: col = d2.Count ' index
      Tstat(lig, col) = Tstat(lig, col) + TblE(i, c)
      TblTotLig(lig) = TblTotLig(lig) + TblE(i, c)
      TblTotCol(col) = TblTotCol(col) + TblE(i, c)
   Next c
  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 Tbl() n'est pas trié.
La table TblRes() est indexée par le dictionnaire pour permettre un accès plus rapide à chaque ligne de la table.

Regroupe Sous Total

Sub RegroupeSousTotall()
  Set d1 = CreateObject("Scripting.Dictionary")
  Set f1 = Sheets("données")
  Tbl = f1.Range("A2:D" & f1.[A65000].End(xlUp).Row).Value
  Ncol = 4
  Dim TblRes(): ReDim TblRes(1 To UBound(Tbl), 1 To Ncol)
  For ligne = 1 To UBound(Tbl)
  clé = Tbl(ligne, 1)
  If d1.exists(clé) Then
     lig = d1(clé)
  Else
    d1(clé) = d1.Count + 1: lig = d1.Count ' index
    For k = 1 To 3: TblRes(lig, k) = Tbl(ligne, k): Next k
  End If
  TblRes(lig, 4) = TblRes(lig, 4) + Tbl(ligne, 4)
Next ligne
Set f2 = Sheets("résultats")
f1.[a1].Resize(, Ncol).Copy f2.[a1]
f2.[a2].Resize(d1.Count, Ncol) = TblRes
End Sub

On regroupe les lignes suivant la 1ere colonne en effectuant un sous total et un cacul du nombre de villes distinctes.

Regroupe Sous Total Nb villes distinctes
Regroupe Sous Total Nb villes distinctes MAC
Regroupement 2 Critères Saut de ligne 3

Sub RegroupeSousTotallNbVillesDistinctes()
  Set d1 = CreateObject("Scripting.Dictionary")
  Set d2 = CreateObject("Scripting.Dictionary")
  Set f1 = Sheets("données")
  Tbl = f1.Range("A2:D" & f1.[A65000].End(xlUp).Row).Value
  Ncol = 5
  Dim TblRes(): ReDim TblRes(1 To UBound(Tbl), 1 To Ncol)
  For ligne = 1 To UBound(Tbl)
    clé = Tbl(ligne, 1)
    If d1.exists(clé) Then
      lig = d1(clé)
    Else
      d1(clé) = d1.Count + 1: lig = d1.Count ' index
      For k = 1 To 2: TblRes(lig, k) = Tbl(ligne, k): Next k
    End If
    TblRes(lig, 3) = TblRes(lig, 3) + Tbl(ligne, 4)
     clé2 = Tbl(ligne, 1) & "|" & Tbl(ligne, 3)
     If Not d2.exists(clé2) Then
       TblRes(lig, 4) = TblRes(lig, 4) + 1
       TblRes(lig, 5) = TblRes(lig, 5) & Tbl(ligne, 3) & " ": d2(clé2) = ""
     End If
  Next ligne
  Set f2 = Sheets("résultats")
   f2.[a2].Resize(d1.Count, Ncol) = TblRes
End Sub

Autres exemples

Regroupe Sous Total
Regroupe colonne avec saut de ligne
Regroupe colonne avec saut de ligne2
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)
     clé = Tbl(ligne, 1)
     If d1.exists(clé) Then lig = d1(clé) Else d1(clé) = d1.Count + 1: lig = d1.Count ' index
     TblRes(lig, 1) = clé
     For col = 2 To Ncol
       If Tbl(ligne, col) <> "" Then TblRes(lig, col) = TblRes(lig, col) + 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) = 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 MAC
Stat 2 Critères Totaux Trié
Stat 2 Critères Maximum
Regroupement 2 Critères Saut de ligne
Regroupement 2 Critères Saut de ligne 2

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
  Set Result = f.Range("f1")     ' Adresse résultat
  Set d1 = CreateObject("Scripting.Dictionary") ' Dictionnaire index pour rapidité
  Set d2 = CreateObject("Scripting.Dictionary")
  Dim TblTot(): ReDim TblTot(1 To UBound(TblBD), 1 To UBound(TblBD, 2))
  Dim TblTotLig(): ReDim TblTotLig(1 To UBound(TblBD))
  Dim TblTotCol(): ReDim TblTotCol(1 To UBound(TblBD, 2))
  For i = LBound(TblBD) To UBound(TblBD)
    clé1 = TblBD(i, colCrit1): If d1.exists(clé1) Then lig = d1(clé1) Else d1(clé1) = d1.Count + 1: lig = d1.Count
    clé2 = TblBD(i, colCrit2): If d2.exists(clé2) Then col = d2(clé2) Else d2(clé2) = 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
  Result.Offset(1).Resize(d1.Count, 1) = Application.Transpose(d1.keys) ' titre lignes
  Result.Offset(, 1).Resize(1, d2.Count) = d2.keys ' titres colonnes
  Result.Offset(1, 1).Resize(d1.Count, d2.Count) = TblTot ' stat 2D
  Result.Offset(d1.Count + 1, 1).Resize(, d2.Count) = TblTotCol ' totaux colonnes
  Result.Offset(1, d2.Count + 1).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

Rapport 2 Critères croisé
Simul TCD

Sub Stat2DTab()
  Set f = Sheets("BD")
  TblBD = f.Range("A2:C" & f.[A65000].End(xlUp).Row).Value ' Array pour rapidité
  colCrit1 = 1: colCrit2 = 3: colOper = 2
  Set AdrResult = f.Range("f1")                        ' Adresse résultat
  Set d1 = CreateObject("Scripting.Dictionary") ' Dictionnaire index pour rapidité
  Set d2 = CreateObject("Scripting.Dictionary")
  Dim TblRes(1 To 100, 1 To 100)
  For i = LBound(TblBD) To UBound(TblBD)
    clé1 = TblBD(i, colCrit1): If d1.exists(clé1) Then lig = d1(clé1) Else d1(clé1) = d1.Count + 1: lig = d1.Count
    clé2 = TblBD(i, colCrit2): If d2.exists(clé2) Then col = d2(clé2) Else d2(clé2) = d2.Count + 1: col = d2.Count
    TblRes(lig, col) = TblBD(i, colOper)
  Next i
  AdrResult.Offset(1).Resize(d1.Count, 1) = Application.Transpose(d1.keys) ' titre lignes
  AdrResult.Offset(, 1).Resize(1, d2.Count) = d2.keys             ' titres colonnes
  AdrResult.Offset(1, 1).Resize(d1.Count, d2.Count) = TblRes  ' résultat
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

Sub Stat2D()
  Set f1 = Sheets("data")
  Set d1 = CreateObject("Scripting.Dictionary") ' lignes
  Set d2 = CreateObject("Scripting.Dictionary") ' colonnes
  Set d3 = CreateObject("Scripting.Dictionary")
  Tbl = f1.Range("a2:d" & f1.[A65000].End(xlUp).Row)
  Dim Tstat(): ReDim Tstat(1 To UBound(Tbl), 1 To UBound(Tbl, 2) + 1)
  Dim Tcol: ReDim Tcol(1 To UBound(Tbl, 2) + 1): Dim Tlig(): ReDim Tlig(1 To UBound(Tbl)) ' totaux lignes &     colonnes
  For i = 1 To UBound(Tbl)
     clé1 = Tbl(i, 1): clé2 = Tbl(i, 3)
     If d1.exists(clé1) Then lig = d1(clé1) Else d3(Tbl(i, 2)) = "": d1(clé1) = d1.Count + 1: lig = d1.Count
     If d2.exists(clé2) Then col = d2(clé2) Else d2(clé2) = d2.Count + 1: col = d2.Count
     Tstat(lig, col) = Tstat(lig, col) + Tbl(i, 4)
     Tlig(lig) = Tlig(lig) + Tbl(i, 4)
     Tcol(col) = Tcol(col) + Tbl(i, 4)
  Next i
  Set résult = Sheets("synthèse").Range("a1")
  résult.Offset(1).Resize(d1.Count, 1) = Application.Transpose(d1.keys) ' titres lignes
  résult.Offset(1, 1).Resize(d3.Count, 1) = Application.Transpose(d3.keys)
  résult.Offset(, 2).Resize(1, d2.Count) = d2.keys                                 ' titres colonnes
  résult.Offset(1, 2).Resize(d1.Count, d2.Count) = Tstat
  résult.Offset(d1.Count + 1, 2).Resize(, d2.Count) = Tcol                                 ' totaux colonnes
  résult.Offset(1, d2.Count + 2).Resize(d1.Count) = Application.Transpose(Tlig)  ' totaux lignes
  '-- tri lignes
  résult.Offset(1).Resize(d1.Count, d2.Count + 3).Sort key1:=[a2], Header:=xlNo
End Sub

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

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

Recherchev avec 2 critères

Rechv 2 critères

Function Rechv2Crit(clé1 As Range, clé2 As Range, Clé1Tbl As Range, Clé2Tbl As Range, RésultTbl As Range, messageErreur)
  Application.Volatile
  Set d = CreateObject("Scripting.Dictionary")
  a = RésultTbl.Value
  b = Clé1Tbl.Value
  c = Clé2Tbl.Value
  TbClé1 = clé1.Value
  TbClé2 = clé2.Value
  For i = LBound(a) To UBound(a)
    d(b(i, 1) & "|" & c(i, 1)) = a(i, 1)
  Next i
  Dim temp(): ReDim temp(LBound(TbClé1) To UBound(TbClé1), 1 To 1)
  For i = LBound(TbClé1) To UBound(TbClé1)
    If d.exists(TbClé1(i, 1) & "|" & TbClé2(i, 1)) Then temp(i, 1) = d(TbClé1(i, 1) & "|" & TbClé2(i, 1)) Else temp(i, 1) =       messageErreur
  Next i
  Rechv2Crit = 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

Principe de la simulation de Dictionary avec 2 collections

Simulation dico avec collection

Sub SimulDictionnareCollection()
  Dim CollecItem As New Collection, CollecCle As New Collection
  nom = "Dupond": age = 30
  CollecCle.Add Item:=nom, Key:=nom
  CollecItem.Add Item:=age, Key:=nom
  nom = "Martin": age = 35
  CollecCle.Add Item:=nom, Key:=nom
  CollecItem.Add Item:=age, Key:=nom
  For i = 1 To CollecCle.Count       ' Toutes les clés et items
    Cells(i + 1, 1) = CollecCle(i)
    Cells(i + 1, 2) = CollecItem(CollecCle(i))
  Next i
End Sub

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

ClasseDictionnaireMacCollection
ClasseDictionnaireMacTableau

Méthodes et propriétés

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

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

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

Code

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

Module de classe DictionnaireMac

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

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

Color Group 1 critère commentaire
Color Group 1 critère HyperLien
Color Group 2 critères commentaire
Color Group 2 critères2

Sub GroupHyperLien()
  Application.ScreenUpdating = False
  Set Rng = Range("A2", [A65000].End(xlUp))
  Rng.Offset(, 1).Resize(, 5).Clear
  Rng.Interior.ColorIndex = xlNone
  couleurs = Array(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 d = CreateObject("Scripting.Dictionary")
  Set d2 = CreateObject("Scripting.Dictionary")
  For Each c In Rng
    If c <> "" Then
      d.Item(c.Value) = d.Item(c.Value) + 1
      d2.Item(c.Value) = d2.Item(c.Value) & CStr(c.Row) & "|"
    End If
  Next c
  nf = ActiveSheet.Name
  For Each c In Rng
   If c.Value <> "" Then
     If d.Item(c.Value) > 1 Then
        nocoul = (Application.Match(c.Value, d.keys, 0)) Mod UBound(couleurs)
        c.Interior.ColorIndex = couleurs(nocoul)
        temp = c.Value
        b = Split(d2(temp), "|")
        For k = 0 To UBound(b) - 1
          ActiveSheet.Hyperlinks.Add Anchor:=Cells(c.Row, k + 2), Address:="", SubAddress:="'" & nf & "'" & "!A" &            b(k), TextToDisplay:=b(k)
        Next k
      End If
    End If
  Next c
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 avec nos de lignes

Liste Doublons nos ligne

Sub ListeDoublons()
  Set d1 = CreateObject("Scripting.Dictionary")
  Set d2 = CreateObject("Scripting.Dictionary")
  For Each c In Range([a2], [a65000].End(xlUp))
     temp = Application.Trim(c.Value)
     If d1.exists(temp) Then
        If InStr(d2(temp), "|") = 0 Then
           d2.Item(temp) = d1(temp) & "|" & c.Row
         Else
           d2.Item(temp) = d2(temp) & "|" & c.Row
         End If
     Else
         d1.Item(temp) = c.Row
      End If
   Next c
   If d2.Count > 0 Then
      [E2].Resize(d2.Count, 1) = Application.Transpose(d2.keys)
      [F2].Resize(d2.Count, 1) = Application.Transpose(d2.items)
   End If
End Sub

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 Communs BD
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 sur plusieurs colonnes & totalisation sur une colonne

Regroupe 4 colonnes & totalisation

Sub Regroupe()
  Set d = CreateObject("Scripting.Dictionary")
  Tbl = Range("A2:E" & [A65000].End(xlUp).Row).Value
  For i = LBound(Tbl) To UBound(Tbl)
    clé = Tbl(i, 1) & "-" & Tbl(i, 2) & "-" & Tbl(i, 3) & "-" & Tbl(i, 4)
    d(clé) = d(clé) + Tbl(i, 5)
  Next i
  [h2].Resize(d.Count) = Application.Transpose(d.keys)
  [i2].Resize(d.Count) = Application.Transpose(d.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

Liste des valeurs uniques pour chaque code

Liste valeurs uniques par code

Sub DicoClassique()
  Set f = Sheets("bd")
  Tbl = f.[A1].CurrentRegion.Value
  NbLig = UBound(Tbl)
  Set dcode = CreateObject("scripting.dictionary")
  dcode.CompareMode = vbTextCompare ' ignore la casse
  For lig = 2 To NbLig ' remplissage dictionnaire
    dcode(Tbl(lig, 1)) = ""
  Next lig
  Set d = CreateObject("scripting.dictionary")
  d.CompareMode = vbTextCompare ' ignore la casse
  ligne = 1
  For Each code In dcode.keys
    ligne = ligne + 1
    d.RemoveAll
    For lig = 2 To NbLig ' remplissage dictionnaire
      If Tbl(lig, 1) = code Then d(Tbl(lig, 2)) = ""
    Next lig
    f.Cells(ligne, "e") = code
    f.Cells(ligne, "f").Resize(, d.Count) = d.keys
  Next code
End Sub

Autre méthode + rapide (0,25 sec pour 30.000 lignes)

Liste valeurs uniques par code rapide
Liste valeurs uniques par code rapide2

Sub RegroupeUniquesCode()
  Set f = Sheets("bd")
  Set d = CreateObject("Scripting.Dictionary")
  Set d1 = CreateObject("Scripting.Dictionary")
  Tbl = f.Range("A2:B" & f.[a65000].End(xlUp).Row).Value
  For i = LBound(Tbl) To UBound(Tbl) ' élimination doublons nuances
    If Tbl(i, 2) <> "" Then d1(Tbl(i, 1) & "|" & Tbl(i, 2)) = ""
  Next i
  For Each c In d1.keys ' regroupement par code
    a = Split(c, "|")
    d(a(0)) = d(a(0)) & a(1) & "|"
  Next c
  Set f2 = Sheets("résultat")
  Dim TblRes: ReDim TblRes(1 To d.Count, 1 To 2)
  i = 0
  For Each c In d.keys
    i = i + 1
   TblRes(i, 1) = c: TblRes(i, 2) = d(c)
  Next c
  f2.[A2].Resize(d.Count, 2) = TblRes
  Application.DisplayAlerts = False
  f2.[B2].Resize(d.Count).TextToColumns Other:=True, OtherChar:="|"
  f2.Cells.EntireRow.AutoFit
End Sub

Listes inverses

ListesInverses
ListesInverses2
ListesInverses3
ListesInverses 5

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
ProcheMult3
Proche Société

Synthèse de 2 tableaux

SynthèsexTableaux

Suppression doublons colonne

Suppression doublons en colonnes

Syntheses 3D

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
Fonction Somme3D 2 critères2
Fonction Somme3D 2 critères MAC
Fonction Somme3D 1 col Num
Fonction Somme3D N col Num
Fonction Somme3D N col Num Index
Fonction Somme3D N col Num MAC
Fonction Somme3D N col Num IndexMAC

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

Dico Phrase Mots
Fonction Recherche Mots Phrases

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

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 1 critère

Sub NbUniques()
  Set f = Sheets("bd")
  Tbl = f.Range("A2:B" & f.[A65000].End(xlUp).Row).Value
  Set d = CreateObject("scripting.dictionary") ' dictionnaire des critères
  Set d2 = CreateObject("scripting.dictionary")
  For i = 1 To UBound(Tbl)
   If Not d.exists(Tbl(i, 2)) Then d(Tbl(i, 2)) = 0
    tmp = Tbl(i, 2) & "|" & Tbl(i, 1)
    If Not d2.exists(tmp) Then d2(tmp) = "": d(Tbl(i, 2)) = d(Tbl(i, 2)) + 1
  Next i
  Dim TblS(): ReDim TblS(1 To d.Count, 1 To 2)
  [E2].Resize(d.Count) = Application.Transpose(d.Keys)
  [F2].Resize(d.Count) = Application.Transpose(d.items)
  [E2].Resize(d.Count, 2).Sort key1:=Range("e2"), order1:=xlAscending, Header:=xlNo
End Sub

Version avec un tableau de dictionnaires

Sub NbUniques2()
  Set f = Sheets("bd")
  Tbl = f.Range("A2:B" & f.[A65000].End(xlUp).Row).Value
  Set d = CreateObject("scripting.dictionary") 'critères
  For i = 1 To UBound(Tbl): d(Tbl(i, 2)) = "": Next i 'dictionnaire des critères
  k = 0: For Each c In d.Keys: k = k + 1: d(c) = k: Next c 'indexation des dictionnaires
  Dim TblDict(): ReDim TblDict(1 To d.Count)
  For i = 1 To UBound(TblDict)
    Set TblDict(i) = CreateObject("scripting.dictionary")
  Next i
  For i = 1 To UBound(Tbl)
    NoDico = d(Tbl(i, 2))
    TblDict(NoDico)(Tbl(i, 1)) = ""
  Next i
  For i = 1 To UBound(TblDict): TblDict(i) = TblDict(i).Count: Next i
  [E2].Resize(d.Count) = Application.Transpose(d.Keys)
  [F2].Resize(d.Count) = Application.Transpose(TblDict)
  [E2].Resize(d.Count, 2).Sort key1:=Range("e2"), order1:=xlAscending, Header:=xlNo
End Sub

Sous forme de fonctions persos

Fonction N b Valeurs Uniques 1 critère
Fonction N b Valeurs Uniques 1 critère 2
Fonction N b Valeurs Uniques 1 critère 3
Fonction Nb Valeurs Uniques 1 critère MAC

Function NbValUniques(Valeurs As Range)
  Application.Volatile
  TblVal = Valeurs
  Set d = CreateObject("scripting.dictionary")
  For i = 1 To UBound(TblVal)
    If Not d.exists(TblVal(i, 1)) Then d(TblVal(i, 1)) = d(TblVal(i, 1)) + 1
  Next i
  NbValUniques = d.Count
End Function

Function NbValUniques1crit(Valeurs As Range, Critère1 As Range, crit As String)
  Application.Volatile
  TblVal = Valeurs
  Tcrit1 = Critère1
  critere = crit
  Set d = CreateObject("scripting.dictionary")
  For i = 1 To UBound(TblVal)
    If Tcrit1(i, 1) = crit Then
       If Not d.exists(TblVal(i, 1)) Then d(TblVal(i, 1)) = d(TblVal(i, 1)) + 1
    End If
  Next i
  NbValUniques1crit = d.Count
End Function

Nb Valeurs Uniques 2 critères
Fonction Nb Valeurs Uniques 2 critères
Fonction Nb Valeurs Uniques 2 critères croisé
Fonction Nb Valeurs Uniques 2 critères MAC

Compte les noms d'un champ

Compte le nombre de noms d'un champ. On peut définir l'ordre croissant ou décroissant.

Compte Noms Champ
Compte Noms Champ PC & MAC
Compte Noms Champ 3D PC & MAC

-sélectionner D2:E40
=comptenoms(B2:B20;2;2)
-Valider avec maj+ctrl+entrée

Function CompteNoms(champ As Range, ColTri, Ordre)
  Set d = CreateObject("scripting.dictionary")
  For Each c In champ
    a = Split(c, "-")
    For i = LBound(a) To UBound(a)
      tmp = Trim(a(i))
      d(tmp) = d(tmp) + 1
    Next i
  Next c
  i = 0
  n = Application.Caller.Rows.Count
  ReDim b(1 To n, 1 To 2)
  For Each c In d.keys
    i = i + 1
    b(i, 1) = c: b(i, 2) = d(c)
  Next c
  TriD2col b, LBound(b), d.Count, ColTri, Ordre
  CompteNoms = b
End Function

Rapport

On veut regrouper les dates (colonne A) par Séance (colonnes B et C) pour chaque adhérent.

Rapport

Sub RapportDic()
  Application.ScreenUpdating = False
  Set f1 = Sheets("planning")
  Set AdrResult = Sheets("Rapport").Range("A1")
  TblE = f1.Range("A2").CurrentRegion.Value2      ' Table entrée
  For Adh = 1 To Ubound(TblE,2)-1
    n = 0: i = 2
   Set d = CreateObject("scripting.dictionary")
   For i = 2 To UBound(TblE)
     clé = TblE(i, Adh + 1)
     If d.exists(clé) Then d(clé) = d(clé) & "|" & TblE(i, 1) Else d(clé) = TblE(i, 1)
   Next i
   AdrResult.Offset(, (Adh - 1) * 3) = TblE(1, Adh + 1)
   For Each clé In d
     AdrResult.Offset(1 + n, (Adh - 1) * 3) = clé
     AdrResult.Offset(1 + n, (Adh - 1) * 3).Interior.ColorIndex = 4
     Tbl = Split(d(clé), "|")
     AdrResult.Offset(n + 1, (Adh - 1) * 3 + 1).Resize(UBound(Tbl) + 1) = Application.Transpose(Tbl)
     AdrResult.Offset(n + 1, (Adh - 1) * 3 + 1).Resize(UBound(Tbl) + 1).NumberFormat = "dd/mm/yyyy"
     AdrResult.Offset(1 + n, (Adh - 1) * 3 + 1).Resize(UBound(Tbl) + 1).BorderAround Weight:=xlThin
     n = n + UBound(Tbl) + 2
   Next clé
  Next Adh
End Sub

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

Sur l'exemple ci dessous, pour une BD de 60.000 lignes et 2x400 formules,
On obtient un temps de recalcul de 1,2 sec contre 15 sec avec Sommeprod()

MatricielPerso
SommeSi 1 critère
SommeSi 2 critères
SommeSi 3 critères

Somme d'une BD par catégorie

On veut la somme du CA pour le secteur primaire (secteurs A,B,C)

=SOMME(SI(ESTNUM(EQUIV(Secteur;SecteurPri;0));CAHT))

SommeBDClasse
SommeBDClasse2

Maj colonne avec Dictionary (0,17 sec) au lieu VLookUp (7 secondes)

On a une table de 20.000 items.
On veut mettre à jour une colonne de 2700 items référençant cette table

Maj VlookUp

Sub RechvM2()
  Application.ScreenUpdating = False
  Set clé = Range("F2:F2673") ' valeurs cherchées
  Set résult = Range("G2:G2673")
  colResult = 2
  For i = 1 To clé.Count
    tmp = clé.Cells(i, 1)
    résult.Cells(i, 1) = Application.VLookup(tmp, [matable], colResult, False)
  Next i
End Sub

avec un dictionnaire (0,17 seconde)

Sub RechvM()
  Set clé = Range("F2:F2673") ' valeurs cherchées
  Set résult = Range("G2:G2673")
  colResult = 2
  messageErreur = "inconnu"
  Set d = CreateObject("Scripting.Dictionary")
  a = [matable].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), 1 To 1)
  For i = LBound(b) To UBound(b)
     If d(b(i, 1)) <> "" Then temp(i, 1) = d(b(i, 1)) Else temp(i, 1) = messageErreur
  Next i
  résult.Value = temp
End Sub

Fusion de 2 Arrays une dimension

Fusion 2 Arrays

Sub EssaiFusionTBl()
  Set f = Sheets("feuil1")
  Tbl1 = Application.Transpose(f.Range("a2:a" & f.[A65000].End(xlUp).Row))
  Tbl2 = Application.Transpose(f.Range("b2:b" & f.[b65000].End(xlUp).Row))
  Tbl3 = FusionTbl(Tbl1, Tbl2)
'[D2].Resize(UBound(Tbl3)) = Application.Transpose(Tbl3)
End Sub

Function FusionTbl(a, b)
  Set d = CreateObject("scripting.dictionary")
  For i = 1 To UBound(a): d(a(i)) = "": Next i
  For i = 1 To UBound(b): d(b(i)) = "": Next i
  FusionTbl = d.keys
End Function

Recopie rapide de lignes d'un champ

On veut extraire certaines lignes d'un champ d'une feuille pour les recopier sur une autre feuille.

Recopie rapide de lignes d'un champ

Sub copieLignes()
  Set f = Sheets("Tableau_1")
  TblE = f.Range("A2:O" & f.[A65000].End(xlUp).Row).Value
  Set d = CreateObject("scripting.dictionary")
  For i = 1 To UBound(TblE)
    clé = TblE(i, 1) & "|" & TblE(i, 3) & "|" & TblE(i, 4) & "|" & TblE(i, 5)
    d(clé) = i ' index
  Next i
  Set f = Sheets("Tableau_2")
  TblS = f.Range("A2:D" & f.[A65000].End(xlUp).Row).Value
  Dim TblS2(): ReDim TblS2(1 To UBound(TblS), 1 To 7)
  Ncol = UBound(TblS, 2)
  For i = 1 To UBound(TblS)
    clé = TblS(i, 1) & "|" & TblS(i, 2) & "|" & TblS(i, 3) & "|" & TblS(i, 4)
    ligne = d(clé)
    For k = 1 To 7
      TblS2(i, k) = TblE(ligne, k + 8)
    Next k
  Next i
  f.[E2].Resize(UBound(TblS2), UBound(TblS2, 2)) = TblS2
End Sub

Synthèse de données

On sélectionne les lignes qui contiennent un des mots d'une liste de mots-clés.

Synthèse données

Option Compare Text
Sub essai()
  Set d = CreateObject("scripting.dictionary")
  Set f1 = Sheets("base de données")
  Set f2 = Sheets("MotsCherchés")
  BD = f1.Range("A2:C" & f1.[A65000].End(xlUp).Row).Value2
  NbCol = UBound(BD, 2)
  Dim Result()
  n = 0
  mots = f2.Range("A1:A" & f2.[A65000].End(xlUp).Row).Value
  For i = 1 To UBound(BD)
    For k = 1 To NbCol
      For m = 1 To UBound(mots)
        If BD(i, k) Like "*" & mots(m, 1) & "*" Then
          temp = "": For v = 1 To NbCol: temp = temp & BD(i, v): Next v
          If Not d.exists(temp) Then
             n = n + 1: ReDim Preserve Result(1 To NbCol + 1, 1 To n): d(temp) = n
             For j = 1 To NbCol: Result(j + 1, n) = BD(i, j): Next j
           Else
             n = d(temp)
           End If
           Result(1, n) = Result(1, n) & mots(m, 1) & " "
         End If
       Next m
      Next k
    Next i
    f1.[F2:M10000].ClearContents
    f1.[f2].Resize(n, NbCol + 1) = Application.Transpose(Result)
End Sub

Comparaison Find et dictionnaire index

Pour un tableau de 100.0000 lignes et 100 recherches, le temps avec un tableau indexé par un dictionnaire est 10 fois inférieur au temps avec Find.

Compare Find Dictionnaire

Sub essaiFind()   ' 3 sec
  clé = "Nom100000"
  For i = 1 To 100 ' 100 recherches
   Set result = [A2:A100001].Find(what:=clé)
  Next i
  MsgBox result.Offset(, 1).Value
End Sub

Sub essaiDico()  ' 0,3 sec
  Set d = CreateObject("scripting.dictionary")
  TblBD = [A2:B100001].Value
  For i = 1 To UBound(TblBD) ' création index
    d(TblBD(i, 1)) = i
  Next i
  clé = "Nom100000"
  For i = 1 To 100 ' 100 recherches
    pos = d(clé)
    ville = TblBD(pos, 2)
  Next i
  MsgBox ville
End Sub