Les variables tableaux (Array)

Accueil

 

Déclaration de d'une variable tableau (Array)
Lbound/Ubound
Tableau (Array) à 2 dimensions
Redimensionnement d'un tableau(Array)
Array
Arrays Emboités
Arrays pré-remplis
Application.Transpose
Arrays 2D pré-remplis avec Evaluate
Transfert d'un champ dans un tableau (Array)
Transfert d'un tableau(Array) dans un champ
Suppression de lignes vides d'un Array
Filter
Filtre lignes & colonnes d'un Array multi-colonnes
Extraction d'une partie d'un Array dans un autre Array
Extraction colonne ou ligne d'un tableau 2D (Array) dans un champ
Extraction d'une colonne de tableau (Array) dans un autre tableau(Array)
Remplacement d'un Array 2D par un dictionnaire multi-colonnes
Transfert d'un champ discontinu dans un tableau (Array)
Extraction d'éléments discontinus d'un champ ou d'un Array dans un Array
Extraction d'un Array
Suppression de lignes d'un Array 2D
Filtre des colonnes d'un Array 2D
Filtre des lignes d'un Array multi-dimensions en fonction d'une clé
Suppresion de lignes vides d'un Array 2D
Suppression de lignes d'un Array 2D en fonction d'une clé
Filtre des lignes & colonnes d'un Array
Remplacement d'un Array 2D par un un dictionnaire multi-colonnes
Recherche dans un Array avec Equiv()
Recherche rapide dans une colonne d'un tableau 2D
Filtre Array colonnes
Filtre Array lignes & Suppression lignes
Filtre des lignes et colonnes d'un Array
Fonction de suppression de doublons d'un Array ou champ
Fusion verticale de 2 Arrays 1D
Fusion verticale de 2 Arrays 2D
Fusion horizontale de 2 Arrays 1D ou 2D
Comparaison de 2 Arrays: Fusion de 2 Arrays , communs de 2 Arrays et différence de 2 Arrays
Fonction Sans doublons trié d'un tableau (Array)
Filtrage lignes/colonnes d'une BD avec 1 ou 2 critères
Sous-total tableau trié
Sous total d'un tableau 2D avec indexation tableau par dictionnaire
Fusion de 2 tableaux
Regroupement avec indexation tableau par dictionnaire
Statistiques 2D
Nombre d'éléments occupés d'un tableau avec NbVal()
Somme d'un tableau avec Somme()
Position d'un élément dans un Array
Tri Quick-sort d'un tableau (Array) à 1 dimension
Tri croissant/décroissant
Tri Shell d'un Array
Tri Shell/Metzner d'un Array
Tri Quick-sort d'un tableau (Array) à 2 dimensions
Tri multi-critères d'un tableau (Array) à 2 dimensions
Tri multi-critères d'un tableau (Array) à 2 dimensions avec index
Tri Multi-critères avec SortedList
Tri ListBox
Tri d'un tableau (Array)de structures
Tri avec la classe Tableau
Tri d'un tableau (Array) à l'aide du tableur
Tri multi-zones
Fonction liste triée
Fonction de tri multi-zones
Fonction de consolidation multi-zones
Fonction de tri sans doublons
Choix feuille
ArrayList
Tri avec SortedList
Différence entre 2 tableaux (Arrays)
Split/Join
Transfert 1 ligne d'un tableau 2 dimensions dans tableau 1 dimension
Remplissage d'un tableau 2 dimensions
Recherche dans dans la première colonne d'un tableau à 2 dimensions Transposition de tableau
Indexation d'un tableau 2D avec Dictionary pour augmenter la vitesse
Exemples divers

 

Dim
Lbound
Ubound
Option Base
Redim
Redim Preserve
Split/Join
Array

Les variables tableaux (Arrays) permettent de stocker des valeurs accessibles par VBA.
-On peut accéder aux éléments d'un tableau par un indice.
-La vitesse d'exécution de VBA est beaucoup plus rapide dans les Arrays que dans les cellules du tableur:
Par ex, le temps de remplissage de 30.000 cellules est de 4s.
Pour un tableau de 30.000,le temps est de 0,01s.

 

a(1)

a(2)

a(3)

a(4)

a(5)

Tableau à 1 dimension a(1 To 5)

aa

bb

cc

dd

ee

  

Tableau à 2 dimensions b(3,2)

11

22

33

44

55

66

Déclaration des tableaux (Arrays)

Dim tableau(taille)
Dim tableau(indice1bas TO indice1Haut,indice2Bas TO indice2Haut,...)

Tableau

Sub Tableau1()
  Dim a(1 To 5) ' 5 lignes
  '------ remplissage du tableau a()
  a(1) = "aa"
  a(2) = "bb"
  a(3) = "cc"
  a(4) = "dd"
  a(5) = "ee"
  '------affichage tableau a() par une boucle
  For i = 1 To 5
     Cells(i, 1) = a(i)
  Next i
End Sub

Autre exemple

Sub Tableau2()
  Dim a(1 To 5)
  '------ remplissage du tableau a() par une boucle
  For i = 1 To 5
     a(i) = i
  Next i
  '------affichage tableau a()
  For i = 1 To 5
    Cells(i, 1) = a(i)
  Next i
End Sub

On obtient

1
2
3
4
5

Autres syntaxes :

Dim a(5)             ' 6 lignes: 0 à 5
Dim b(1 To 10)    ' 10 lignes
Dim c(10, 3)        ' 10 lignes, 3 colonnes
Dim d(1 To 10, 1 To 3) ' 10 lignes, 3 colonnes
semaine = Array("Lun", "Mar", "Mer", "Jeu", "Ven", "Sam", "Dim")

Transfert d'un tableau a() dans un tableau b()

Dim a(1 To 5) ' 5 lignes
'------ remplissage du tableau a()
a(1) = "aa"
a(2) = "bb"
a(3) = "cc"
a(4) = "dd"
a(5) = "ee"
'------- transfert
b = a             ' a-->b
'------affichage tableau b()
For i = 1 To 5
   Cells(i, 1) = b(i)
Next i

Effacement d'un tableau (Erase tableau)

Erase a

Fusion et insersection de tableaux

Fusion Intersection tableaux

Lbound(tableau,no_dimension)
Ubound(tableau,no_dimension)

Donne l'indice le plus petit du tableau et le plus grand.

Sub essaiLbound()
  Dim a(10)                ' 11 lignes (0 à 10)
  For i = LBound(a) To UBound(a)
    a(i) = i
  Next i
End Sub

Sub essaiLbound()
  Dim b(1 To 10, 1 To 3)
  MsgBox UBound(b, 1) ' première dimension
  MsgBox UBound(b, 2) ' deuxième dimension
End Sub

Tableau 2 dimensions (Array)

Sub Tab2D()
  Dim a(1 To 3, 1 To 2) ' 3 lignes x 2 colonnes
  a(1, 1) = 11
  a(1, 2) = 12
  a(2, 1) = 21
  a(2, 2) = 22
  a(3, 1) = 31
  a(3, 2) = 32
  For lig = LBound(a, 1) To UBound(a, 1)
     For col = LBound(a, 2) To UBound(a, 2)
        Cells(lig, col) = a(lig, col)
     Next col
  Next lig
End Sub

On obtient

11   12
21   22
31   32

Option Base

-Par défaut, le premier élément d'un tableau est l'élément 0
-Avec Option Base 1, le premier élément par défaut devient l'élément 1

Option Base 1
Sub essai()
  Dim a(10)
  For i = 1 To 10 ' ou For i = LBound(a) To UBound(a)
     a(i) = Rnd
  Next i
End Sub

Redimentionnement d'un tableau (Array)

Redim tableau(taille)
Redim Preserve tableau(taille)

Redim tableau(taille) permet de redimentionner un tableau dynamiquement avec une taille qui n'est pas encore connue au moment de la déclaration.

Sub essaiRedim()
  Dim a() As Integer
  '
  '
  n = 5
  ReDim a(n)
  For i = 1 To n
    a(i) = Rnd() * 100
  Next i
End Sub

L'option Preserve permet de conserver les valeurs déjà présentes dans le tableau..

Sub EssaiRedimPreserve()
  Dim a()
  n = 5
  ReDim a(1 To n)
  For i = LBound(a) To UBound(a)
    a(i) = i
  Next i
  n = 10
  ReDim Preserve a(1 To n) ' les anciennes valeurs du tableau sont préservées
  For i = 6 To n
    a(i) = i
  Next i
  For i = LBound(a) To UBound(a)
    Cells(i, 1) = a(i)
  Next i
End Sub

Pour un tableau à plusieurs dimensions et avec l’option Preserve, seule la dernière dimension peut être modifiée

Dim b()
ReDim Preserve b(1 To 5, 1 To 2)
ReDim Preserve b(1 To 5, 1 To 3)

tableau=Array(val1,val2,...)

Ci dessous, le tableau a() est rempli avec 3,4,5,6,...

Sub EssaiArray()
  a = Array(3, 4, 5, 6, 7, 8, 36, 10, 37, 38, 39, 14, 15)   ' tableau dimension 13
  For i = LBound(a) To UBound(a)   ' 0 à 12
     Cells(i + 1, 1) = a(i)
  Next i
End Sub

Avec Evaluate

Sub essaiEvaluate()
  Tbl = Evaluate("{1,2,3,4,5}")
  For i = LBound(Tbl) To UBound(Tbl) ' 1 à 5
    Cells(i, 1) = Tbl(i)
  Next i
End Sub

Sub essaiArrayEvaluate2()
  Tbl = [{"A","B","C","D","E"}]
  For i = LBound(Tbl) To UBound(Tbl) ' 1 à 5
    Cells(i, 1) = Tbl(i)
  Next i
End Sub

Avec SPLIT

Sub essaiSplit()
  Tbl = Split("A,B,C,D,E", ",")
  For i = LBound(tbl) To UBound(tbl) ' 0 à 4
    Cells(i + 1, 1) = tbl(i)
  Next i
End Sub

Array emboîtés

Tbl() est un tableau à 1 dimension (1 à 3). On remarquera la syntaxe pour accéder à un élément des tableaux emboités. Il faut que les tableaux a,b,c aient la même taille. On peut transposer le tableau Tbl() pour obtenir un tableau classique à 2 dimensions.

Sub TableauEmboités()
  Dim Tbl(1 To 3)
  a = Array("a", "b", "c", "d")
  b = Array("e", "f", "g", "h")
  c = Array(1, 2, 3, 4)
  Tbl(1) = a
  Tbl(2) = b
  Tbl(3) = c
  For lig = LBound(Tbl) To UBound(Tbl)
     For col = LBound(a) To UBound(a)
        Cells(lig, col + 1) = Tbl(lig)(col)
     Next col
   Next lig
End Sub

On obtient

a b c d
e f g h
1 2 3 4

Avec

aa = Application.Index(Tbl, , 1)
[h1].Resize(UBound(aa)) = aa

On obtient

a
e
1

Avec

bb = Application.Index(Tbl, 1)
[h1].Resize(, UBound(bb)) = bb

On obtient

a b c d

Autre écriture

Sub ArrayEmboités()
  Tbl = Array( _
  Array("a", "b", "c", "d"), _
  Array("e", "f", "g", "h"), _
  Array(1, 2, 3, 4))
  For lig = LBound(Tbl) To UBound(Tbl)
    For col = 0 To 3
       Cells(lig + 1, col + 1) = Tbl(lig)(col)
    Next col
  Next lig
End Sub

Autre exemple

Sub TableauxEmboites()
   Dim a(1 To 4)
   Dim b(1 To 4)
   Dim c(1 To 4)
   For i = 1 To 4
     a(i) = i
     b(i) = i * 2
     c(i) = i * 3
   Next i
   Tbl = Array(a, b, c)       ' Tbl() est un tableau à 1 dimension (0 à 2)
   For lig = 0 To 2
      For col = 1 To 4
        Cells(lig+1,col)= Tbl(lig)(col)
     Next col
   Next lig
End Sub

On obtient

1 2 3 4      ' tableau a
2 4 6 8      ' tableau b
3 6 9 12    ' tableau c

Autre exemple

Sur cet exemple, on emboite 2 tableaux 2D a(,) et b(,) dans un Array().

Sub TableauxEmboites3()
   Dim a(1 To 3, 1 To 2)       ' 2D
   Dim b(1 To 3, 1 To 2)       ' 2D
   For lig = LBound(a, 1) To UBound(a, 1)
      For col = LBound(a, 2) To UBound(a, 2)
        a(lig, col) = lig + (col - 1) * 3
        b(lig, col) = lig + (col - 1) * 3 + 100
      Next col
    Next lig
    Tbl = Array(a, b)     ' 1D (0 à 1)avec 2 tableaux emboités
    MsgBox Tbl(0)(1, 1) ' affiche 1
    d = Tbl(0)               ' on extrait d() 2 dimensions
    e = Tbl(1)               ' on extrait e() 2 dimensions
    [A1].Resize(UBound(d, 1), UBound(d, 2)) = d
    [D1].Resize(UBound(e, 1), UBound(e, 2)) = e
    MsgBox Tbl(0)(1, 1) ' affiche 1
    MsgBox Tbl(1)(1, 1) ' affiche 101
End Sub

On obtient

a()         b()
1   4       101 104
2   5       102 105
3   6       103 106

Autre exemple

Private Sub UserForm_Initialize()
  Dim a(1 To 3)
  a(1) = Range("A2:A5").Value
  a(2) = Range("A10:A15").Value
  a(3) = Range("A20:A25").Value
  For i = 1 To 3
    For j = 1 To UBound(a(i))
      If a(i)(j, 1) <> "" Then ComboBox1.AddItem a(i)(j, 1)
    Next j
  Next i
End Sub

Tri d'Array emboîtés

Tri Array emboités

Sub TriTableauEmboités()
  n = 5
  Dim Tbl(): ReDim Tbl(1 To n)
  For i = 1 To n
     Tbl(i) = Array(Cells(i, 1), Cells(i, 2), Cells(i, 3))
  Next i
  '---- Tri Bubble
  For i = 1 To n
    For j = i To n
      If Tbl(j)(0) < Tbl(i)(0) Then
         tmp = Tbl(j): Tbl(j) = Tbl(i): Tbl(i) = tmp
      End If
    Next j
  Next i
  '-- transfert feuille
  ' ou [J1:L5] = Application.Transpose(Application.Transpose(Tbl))
  For lig = 1 To n
    For col = 0 To 2
      Cells(lig, col + 10) = Tbl(lig)(col)
    Next col
  Next lig
End Sub

Transfert d'une ligne d'un tableau dans le tableur avec des tableaux emboités

L'organisation sous forme de tableaux emboités permet de manipuler des lignes de tableaux plus simplement.

TransfertLigne

Sub TransfertLigneTableauAvecTableauxEmboités()
  Dim Tout(1 To 4)
  '--Transfert du champ [A1:D3] dans Tout()
  For lig = 1 To 4
    Tout(lig) = [A1:D1].Offset(lig - 1)
  Next lig
  '-- extraction d'une ligne dans le tableur
  [A6].Resize(, 4) = Tout(2)
  '-- extraction d'une ligne dans un tableau a()
  a = Tout(2)
  [A8].Resize(, 4) = a
  '-- transfert de valeurs dans une ligne du tableau
  Tout(2) = [{1,2,3,4}]
  [A10].Resize(, 4) = Tout(2)
  '---- Modification d'un élément
  Tout(2)(2) = 99
  [A12].Resize(, 4) = Tout(2)
End Sub

Indexer une suite de tableaux a(),b(),c(),...

TableauxIndexés

Sub TableauxIndexés()
  Dim a(1 To 4)
  Dim b(1 To 4)
  Dim c(1 To 4)
  For i = 1 To 4        'remplissage tableaux
    a(i) = i
    b(i) = i * 2
    c(i) = i * 3
  Next i
  tbl = Array(a, b, c) ' Tbl() est un tableau à 1 dimension (0 à 2)

  For col = LBound(tbl) To UBound(tbl)
     Cells(2, 1).Offset(, col).Resize(UBound(a)) = Application.Transpose(tbl(col))
  Next col
End Sub

Concaténation de tableaux

Sub ConcatTableau()
  a = Array(1, 2, 3, 4)
  b = Array(5, 6, 7, 8, 9)
  c = Split(Join(a, ",") & "," & Join(b, ","), ",")
  [A1].Resize(UBound(c) + 1) = Application.Transpose(c)
End Sub

Tableaux à 2 dimensions (Arrays) pré-remplis avec Evaluate

Sub Tableau2Dimensions()
  a = Evaluate("{1,2,3;4,5,6;7,8,9;10,11,12}") ' 1 à 4 x 1 à 3
  For lig = LBound(a, 1) To UBound(a, 1)
     For col = LBound(a, 2) To UBound(a, 2)
       Cells(lig, col) = a(lig, col)
     Next col
  Next lig
End Sub

On obtient

1    2    3
4    5    6
7    8    9
10  11  12

Autre exemple

Sub Tableau2Dimensions2()
  a = [{1,2,3;4,5,6;7,8,9;"aa","bb","cc"}]
  For lig = LBound(a, 1) To UBound(a, 1)
    For col = LBound(a, 2) To UBound(a, 2)
       Cells(lig, col) = a(lig, col)
    Next col
  Next lig
End Sub

On obtient

1   2   3
4   5   6
7   8   9
aa bb cc

Arrays pré-remplis

a = Evaluate("Row(1:10)")                                   ' tableau 2D rempli avec 1,2,3,4,..,10
b = Application.Transpose(Evaluate("Row(1:10)")) ' tableau 1D rempli avec 1,2,3,4,...,10 c = c=Evaluate("Row(1:10)*2-1")                               ' tableau 2D rempli avec 1,3,5,7,9

a = [{1;2;3;4;5;6;7;8;9;10}]                 ' tableau 2D a(1 To 10,1 To 1)
b = [{1,2,3,4,5,6,7,8,9,10}]                   ' tableau 1D b(1 to 10)

Application.Transpose(tableau)

a = Array(1, 2, 3, 4)              ' a(0 To 3)
b = Application.Transpose(a)  ' b(1 To 4,1 To 1)
c = Application.Transpose(b)  ' c(1 To 4)
d = Application.Transpose(c)  ' d(1 To 4,1 To 1)

Temps de remplissage de cellules et de tableau:

  • La vitesse d'exécution de VBA est beaucoup rapide dans les tableaux que dans le tableur:
  • Le temps de remplissage de 30.000 cellules est de 4s. Pour un tableau de 30.000, le temps est de 0,01 s

Sub remplissageTableau()
  Application.ScreenUpdating = False
  Dim a(1 To 30000, 1 To 1)
  t = Timer
  For i = 1 To 30000
    a(i, 1) = Rnd
  Next i
  Range("A1:A30000").Value = a
  MsgBox Timer - t
End Sub

Sub remplissageCellules()
  Application.ScreenUpdating = False
  t = Timer
  For i = 1 To 30000
     Cells(i, 1) = Rnd
  Next i
  MsgBox Timer - t
End Sub

Transfert d’un champ dans un Array

Tableau

Le transfert d’un champ dans un tableau se fait avec :

Tableau=Range(champ).value

On obtient le résultat dans un tableau à 2 dimensions :

Sub TransfertChampTableau2D()
  t = Timer
  a = [A1:C20000].Value
  MsgBox Timer - t              ' 0,015 sec 
  MsgBox LBound(a, 1) & " à " & UBound(a, 1) ' 1 à 20000
  MsgBox LBound(a, 2) & " à " & UBound(a, 2) ' 1 à 3
End Sub

Attention! Si le champ n'a qu'une colonne, le tableau est toujours à 2D (1 à n, 1 à 1)

Pour transférer un champ 1 colonne dans un tableau à 1 dimension

Sub TransfertChamp1ColonneTableau1D()
  t = Timer()
  a = Application.Transpose([a1:A20000])       ' tableau à 1 dimension (1 à 20000)
  MsgBox Timer() - t       ' 0,015 sec
  MsgBox LBound(a) & " à " & UBound(a)
End Sub

Avec boucle

Sub TransfertChampTableau1DAvecBoucle()
  n = 20000
  Dim a()
  ReDim a(1 To n)
  t = Timer
  For i = 1 To n: a(i) = Cells(i, 1): Next i
  MsgBox Timer - t      ' 0,20 sec
End Sub

Transfert d’un tableau (Array) dans un champ

Le transfert d’un tableau dans un champ se fait avec :

Range(Champ)=tableau

Le transfert est très rapide

Tableau à 1 dimension dans un champ

Sub transfertTableau1DChamp()
  Dim a()
  n = 20000
  ReDim a(1 To n)
  For i = 1 To 20000
    a(i) = i
  Next i
  t = Timer
  [A1].Resize(UBound(a)) = Application.Transpose(a)
  MsgBox Timer - t ' 0,01 sec
End Sub

Avec boucle

Sub TransfertTableauChampAvecBoucle()
  Application.ScreenUpdating = False
  n = 20000
  Dim a()
  ReDim a(1 To n)
  For i = 1 To n: a(i) = i: Next i
  t = Timer
  For i = 1 To n: Cells(i, 1) = a(i): Next i
  MsgBox Timer - t   '1,25 sec
End Sub

Tableau (Array) à 2 dimensions dans un champ

Sub transfertTableau2DChamp()
  Dim a()
  Nlig = 20000
  Ncol = 3
  ReDim a(1 To Nlig, 1 To Ncol)
  For L = 1 To Nlig
    For C = 1 To Ncol
       a(L, C) = L * C
    Next C
  Next L
  t = Timer
  [A1].Resize(UBound(a, 1), UBound(a, 2)).Value = a
  MsgBox Timer - t     ' 0,04 sec
End Sub

Attention! Problème d'inversion jour/mois pour les dates avec versions < à 2007

Avec Value2 ou FormulaLocal, les dates ne sont pas inversées (Laeticia90)

[A1].Resize(UBound(a, 1), UBound(a, 2)).Value2= a

Fonction de concaténation d'un champ

Function concatene(champ As Range)
  concatene = Join(Application.Transpose(champ), "")
End Function

Transfert champ discontinu dans une BD

Sub TransfertBD()
  a = Array([B2], [B4], [B6], [B8])
  [F65000].End(xlUp).Offset(1).Resize(, 4) = a
  Range("B2,B4,B6,B8").ClearContents
End Sub

Transfert d'une colonne ou d'une ligne d'un tableau 2D (Array) dans un champ

Tableau
TableauTransfertLigneColonne

Sub TransferColonneTableauChamp()
  Dim a(1 To 3, 1 To 3)
  a(1, 1) = 11
  a(2, 1) = 12
  a(3, 1) = 13
  a(1, 2) = 21
  a(2, 2) = 22
  a(3, 2) = 23
  a(1, 3) = 31
  a(2, 3) = 32
  a(3, 3) = 33
  ' Transfert 2e colonne d'un tableau dans un champ
  [A1].Resize(UBound(a, 1)) = Application.Index(a, , 2)
End Sub

Sub TransferLigneTableauChamp()
  Dim a(1 To 3, 1 To 3)
  a(1, 1) = 11
  a(2, 1) = 12
  a(3, 1) = 13
  a(1, 2) = 21
  a(2, 2) = 22
  a(3, 2) = 23
  a(1, 3) = 31
  a(2, 3) = 32
  a(3, 3) = 33
  ' Transfert 2e ligne d'un tableau dans un champ
  [A1].Resize(UBound(a, 2)) = Application.Transpose(Application.Index(a, 2))
End Sub

Filtre de lignes dans un Array 2D

Sur cet exemple la sélection de 10.000 lignes sur 20.000 lignes prend 0,12 sec

FiltreArrayClé

Sub filtreArrayClé()
  Set f = Sheets("bd")
  Tbl1 = f.Range("A2:D" & f.[A65000].End(xlUp).Row).Value
  ville = "Paris"
  For i = 1 To UBound(Tbl1)
    If Tbl1(i, 3) = ville Then n = n + 1
  Next i
  j = 0
  Dim Tbl2: ReDim Tbl2(1 To n, 1 To UBound(Tbl1, 2))
  For i = 1 To UBound(Tbl1)
    If Tbl1(i, 3) = ville Then j = j + 1: For k = 1 To UBound(Tbl1, 2): Tbl2(j, k) = Tbl1(i, k): Next k
   Next i
   f.[G2].Resize(UBound(Tbl2), UBound(Tbl2, 2)) = Tbl2
End Sub

La fonction FiltreArrayLignes(Tableau,colonne,critère) retourne dans un tableau les lignes vérifiant le critère spécifié. Sur l'exemple,  a = FiltreArrayLignes(Tablo, 3, "Paris") récupère dans un tableau a() les lignes de Paris.

Filtre Array Lignes & Sup Lignes

Sub SelectionLignesColCle()
   Tablo = [A2:D7].Value
   a = FiltreArrayLignes(Tablo, 3, "Paris")    ' On récupère les lignes de Paris en colonne 3
   [G2].Resize(UBound(a), UBound(a, 2)).Value2 = a
End Sub

Suppression de lignes vides d'un Array

Pour 10.000 lignes , le temps est de 0,07 sec

Suppression de lignes vides d'un Array

Sub SupVidesArray()
   Set f = Sheets("bd")
  Tbl1 = f.Range("A2:D" & f.[A65000].End(xlUp).Row).Value
  For i = 1 To UBound(Tbl1)
    If Tbl1(i, 1) <> "" Then n = n + 1
  Next i
  j = 0
  Dim Tbl2: ReDim Tbl2(1 To n, 1 To UBound(Tbl1, 2))
  For i = 1 To UBound(Tbl1)
     If Tbl1(i, 1) <> "" Then j = j + 1: For k = 1 To UBound(Tbl1, 2): Tbl2(j, k) = Tbl1(i, k): Next k
  Next i
  f.[G2].Resize(UBound(Tbl2), UBound(Tbl2, 2)) = Tbl2
End Sub

Extraction d'une colonne d'un Array dans un autre Array

a = [A1:C20000].Value           ' tableau a() : 1 to 20000, 1 to 3
b = Application.Index(a, , 3)    ' tableau b() : 1 to 20000, 1 to 1
c = Application.Transpose(Application.Index(a, , 3)) ' tableau c() : 1 to 20000
MsgBox b(2, 1)
MsgBox c(2)

Remplacement d'un Array 2D par un 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 peut être transféré dans un Array 2D classique b(,) .

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

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

Transfert d'un champ discontinu dans un Array

On veut récupérer les champs discontinus A1:A10,C1:C10,F1:F10 dans un Array Tbl2(,).
( 0,04 sec pour 10.000 lignes)

Champ discontinu Array
ListBox champs discontinus

Sub filtreColonnesArray()
  Set f = Sheets("bd")
  Tbl1 = f.Range("A1:F" & f.[A65000].End(xlUp).Row).Value
  Dim Tbl2: ReDim Tbl2(1 To UBound(Tbl1), 1 To 3)
  j = 0
  For Each k In Array(1, 3, 6)
    j = j + 1
    For i = 1 To UBound(Tbl1): Tbl2(i, j) = Tbl1(i, k): Next i
  Next k
  f.[M1].Resize(UBound(Tbl2), UBound(Tbl2, 2)) = Tbl2
End Sub

Autre méthode

-Le transfert est rapide (0,2 sec pour 10.000 lignes et 3 colonnes).

Champs discontinus dans Array 2D

Sub ChampDiscontinuArray()
  Set d = CreateObject("Scripting.Dictionary")
  a = [A1:F10]
  For i = LBound(a) To UBound(a)
    d(i) = Array(a(i, 1), a(i, 3), a(i, 6))
  Next i
  '----- affichage du tableau dans le tableur
  b = Application.Transpose(Application.Transpose(d.items)) ' dictionnaire dans array b(1 to n,1 to 3)
  [M1].Resize(UBound(b), UBound(b, 2)) = b
End Sub

Avec Arrays emboîtés

Les colonnes peuvent avoir des nombres d'items différents (Ubound(a(col)) donne le nombre d'items de la colonne)

Champs discontinus tableau


Dim a(1 To 3)
a(1) = [A1:A10]
a(2) = [C1:C10]
a(3) = [F1:F10]
lig = 2:  col = 3:  MsgBox a(col)(lig, 1)

ou

Dim a(1 To 3)
a(1) = Application.Transpose([A1:A10])
a(2) = Application.Transpose([C1:C10])
a(3) = Application.Transpose([F1:F10])
lig = 2:   col = 3:  MsgBox a(col)(lig)

ou

Set Rng = Range("A1:A100,C1:C100,F1:F10,K1:K10")
n = Rng.Areas.Count
Dim a(): ReDim a(1 To n)
For i = 1 To n
    a(i) = Rng.Areas(i).Value
Next i
lig = 2:  col = 4:  MsgBox a(col)(lig, 1)

ou

c = Array(1, 3, 6, 11) ' colonnes
n = UBound(c) + 1
Dim a(): ReDim a(1 To n)
For i = 1 To n
    a(i) = Cells(1, c(i - 1)).Resize(10).Value
Next i
lig = 2:  col = 4:  MsgBox a(col)(lig, 1)

tableau=Filter(TableauSource, critère[, include[, compare]])

Filtre un tableau de chaines 1 dimension suivant un critère.
Si l'argument include a la valeur True, la fonction Filter renvoie le sous-ensemble du tableau contenant l'argument match comme sous-chaîne.
Si l'argument include a la valeur False, la fonction Filter renvoie le sous-ensemble du tableau ne contenant pas l'argument match comme sous-chaîne.

Ci dessous, on filtre tous les noms d'un tableau contenant la chaîne Mar

Me.ListBox1.List = Filter(Application.Transpose([liste]), "Mar", True, vbTextCompare)

Balu
Balutin
Borland
Campas
Champollion
Charlie
Martin
Martinet
Miroux
Merinos
Piaget
Pierrot

Filtre

Recherche intuitive dans un formulaire

Permet de rechercher un item en frappant dans un combobox des lettres contenues dans l'item cherché.



Liste intuitive formulaire
Recherche intuitive Société Combobox formulaire

Dim a()
Private Sub UserForm_Initialize()
  a = Application.Transpose([liste])
  Me.ComboBox1.List = a
End Sub

Private Sub ComboBox1_Change()
  If Me.ComboBox1.ListIndex = -1 Then
     Me.ComboBox1.List = Filter(a, Me.ComboBox1.Text, True, vbTextCompare)
     Me.ComboBox1.DropDown
  Else
    ActiveCell = Me.ComboBox1
    Unload Me
  End If
End Sub

La même chose dans le tableur.

Liste intuitive tableur

Filtre multi-colonnes d'un Array en fonction d'une clé

La fonction Filter() n'accepte que les Arrays à 1 dimension.
Cette fonction FiltreMultiCol(Tbl, clé, colclé) filtre un Array multi-colonnes.
FiltreLignesColonnes(Tbl,clé, colClé, ColonnesRésultat)
permet de choisir les colonnes résultats.

Filtre Array Multi-colonnes
Recherche BD avec choix de la colonne de recherche
Recherche BD intuitive avec choix de la colonne de recherche

Option Compare Text
Sub essaiFiltre()
  Set f = Sheets("bd")
  Tbl = f.Range("A3:G" & f.[A65000].End(xlUp).Row).Value
  clé = "Paris": colClé = 6
  b = FiltreMultiCol(Tbl, clé, colClé)
  If Not IsEmpty(b) Then
  Sheets("result").[A2].Resize(UBound(b), UBound(b, 2)) = b
  End If
End Sub

Function FiltreMultiCol(Tbl, clé, colClé)
  Ncol = UBound(Tbl, 2)
  n = 0
  For i = LBound(Tbl) To UBound(Tbl)
    If clé = Tbl(i, colClé) Then n = n + 1
  Next i
  If n > 0 Then
    Dim b(): ReDim b(1 To n, 1 To Ncol)
    n = 0
    For i = LBound(Tbl) To UBound(Tbl)
       If clé = Tbl(i, colClé) Then
            n = n + 1: For k = 1 To Ncol: b(n, k) = Tbl(i, k): Next k
        End If
     Next i
     FiltreMultiCol = b
   End If
End Function

Pour alimenter un ListBox avec Column au lieu de List, on peut utiliser cette fonction qui retourne un Array transposé.

Function FiltreMultiColTransp(Tbl, clé, colClé)
  Dim b(): Ncol=UBound(Tbl, 2)
  n = 0
  For i = LBound(Tbl) To UBound(Tbl)
    If clé = Tbl(i, colClé) Then
       n = n + 1: ReDim Preserve b(1 To Ncol, 1 To n)
       For k = 1 To Ncol: b(k, n) = Tbl(i, k): Next k
    End If
  Next i
  If n > 0 Then FiltreMultiColTransp = b
End Function

Filtre Array Multi-colonnes

FiltreLignesColonnes(Tbl,clé, colClé, ColonnesRésultat)

Sur cette version, on peut choisir les lignes et les colonnes qui sont retournées par la fonction.

Filtre Array Multi-colonnes Lignes colonnes
Filtre Array Multi-colonnes Lignes colonnes recherche clé toutes colonnes

-Sur l'exemple, on filtre l'Array bd pour la ville de Paris en colonne 6 et on récupère les colonnes 1,2,6,7

b = FiltreLignesColonnes(bd,"Paris", 6, Array(1, 2, 6, 7))

-Pour le critère de sélection,on peut spécifier "". On récupère ainsi toutes les lignes et seulement les colonnes spécifiées.

b = FiltreLignesColonnes(bd,"", 6, Array(1, 2, 6, 7)) ' toutes les lignes

-Si on ne spécifie pas de colonnes, toutes les colonnes sont choisies.

b = FiltreLignesColonnes(bd,"Paris", 6) ' toutes les colonnes

Sur cette version, on peut spécifier 1 ou 2 conditions

Function FiltreMultiCol2(Tbl, colClé1, Clé1, ColResult, Optional colClé2, Optional Clé2,ColTri)

Filtre Array Multi-colonnes avec 1 ou 2 conditions
Filtre Array Multi-colonnes avec 1 ou 2 conditions Formulaire

Extraction d'une partie d'un Array dans un autre array

Dans l'exemple ci dessous, nous récupérons dans un Array b() les 20 items de l'Array a() à partir de la position 30

Sub ExtraitArray()
  Dim a(1 To 100)
  For i = 1 To UBound(a): a(i) = i: Next i
  '--- extrait
  Position = 30
  taille = 20
  b = Application.Index(a, Evaluate("Row(" & Position & ":" & Position + taille & ")"))
  [A1].Resize(taille) = b
End Sub

Sur cet exemple, nous découpons un Array en tranches de 10

Sub decoupeArray()
  Dim a(1 To 100)
  For i = 1 To UBound(a): a(i) = i: Next i
  '--- découpe
  pas = 10
  For k = 0 To UBound(a) / pas - 1
    decal = k * pas + 1
    [C1].Resize(pas).Offset(k * (pas + 1)) = Application.Index(a, Evaluate("Row(" & decal & ":" & decal + pas & ")"))
  Next k
End Sub

Extraction de plusieurs éléments discontinus d'un champ ou d'un Array dans un autre Arra avec Application.Index()

La fonction Index(champ;vecteur ligne;vecteur colonne) d'Excel permet de spécifier des vecteurs au lieu de ligne et colonne (cette syntaxe n'est pas documentée dans l'aide Excel).

Pour obtenir ce qui est à l'intersection des lignes 1,3,5,7 et des colonnes 1,3,6 d'un champ

-Sélectionner 4 lignes et 3 colonnes
=INDEX(champ;{1;3;5;7};{1.3.6})
Valider avec maj+ctrl+entrée

En VBA

Set Rng = [A2:H8]
b = Application.Index(Rng, [{1;3;3;5;7}], [{1,3,6}])
[H2].Resize(UBound(b), UBound(b, 2)) = b

Suppression de lignes d'un champ ou d'un Array

Sur cet exemple, on supprime 1 ligne sur 2 dans un champ (1 sec pour 10.000 lignes)

Sup 1 Lifigne sur 2

Sub Sup1LigneSur2()
  Set Rng = Range("A2:J100")
  b = Application.Index(Rng, Evaluate("Row(1:" & Rng.Rows.Count \ 2 & ")*2-1"), _
  Application.Transpose(Evaluate("Row(1:" & Rng.Columns.Count & ")")))
  [T2].Resize(UBound(b), UBound(b, 2)) = b
End Sub

Sur cet exemple, on supprime les lignes d'un Array a() pour la ville Issy (0,22 sec pour un Array 10.000 lignes et 4 colonnes). Cette méthode est sensiblement moins rapide que la méthode classique
(0,08 sec Sup Lignes Array).

Sup lignes clé

balu

30

Lyon

25/01/2014

dupond

44

Paris

25/02/2014

dupont

66

Paris

01/01/2014

Durand

35

Issy

25/01/2014

Martin

23

Issy

12/10/2013

Zoé

33

Lyon

12/10/2013

Sub SuppressionLignesCle()
  a = [A2:D7].Value
  Dim tmp(): ReDim tmp(1 To UBound(a))
  For i = LBound(a) To UBound(a)
    If a(i, 3) <> "Issy" Then n = n + 1: tmp(n) = i
  Next
  ReDim Preserve tmp(1 To n)
  a = Application.Index(a, Application.Transpose(tmp), Application.Transpose(Evaluate("Row(1:" & UBound(a, 2) & ")")))
  [g2].Resize(UBound(a), UBound(a, 2)) = a
End Sub

Prendre les n premières lignes d'un Array

Sub prendrePremLignesArray()   " 0,1s pour 3000 lignes
  a = Range("A1:E10000")
  n = 3000
  b = Application.Index(a, Evaluate("Row(1:" & n & ")"),     Application.Transpose(Evaluate("Row(1:" & UBound(a, 2) & ")")))
  [g2].Resize(UBound(b), UBound(b, 2)) = b
End Sub

Permuter 2 colonnes d'un champ

Set Rng = [A2:B20]
Rng.Value = Application.Index(Rng, Evaluate("Row(1:" & Rng.Rows.Count & ")"), Array(2, 1))

Extraction de colonnes entières d'un champ ou d'un Array dans un autre Array.

On veut extraire les colonnes 1,3,6 du champ [A2:F8].
Pour le paramètre vecteur ligne de Index(champ;vecteur ligne;vecteur colonne), il faut donner un vecteur contenant les numéros de ligne 1,2,3,4,5,6,7 et pour le paramètre colonne, il faut donner un vecteur contenant les numéros des colonnes 1,3,6.

Extraction Tableau

Champ

Set Rng = [A2:F8]
Dim tmp(): ReDim tmp(1 To Rng.Rows.Count, 1 To 1): For i = 1 To Rng.Rows.Count: tmp(i, 1) = i: Next
b = Application.Index(Rng, tmp, Array(1, 3, 6))
[M2].Resize(UBound(b), UBound(b, 2)) = b

ou

 Set Rng = [A2:F8]
 b = Application.Index(Rng, Evaluate("Row(1:" & Rng.Rows.Count & ")"), Array(1, 3, 6))
 [M2].Resize(UBound(b), UBound(b, 2)) = b

Array

a =[A2:F8].Value
Dim tmp(): ReDim tmp(1 To UBound(a), 1 To 1): For i = 1 To UBound(a): tmp(i, 1) = i: Next
b = Application.Index(a, tmp, Array(1, 3, 6))
M2].Resize(UBound(b), UBound(b, 2)) = b

ou

a = [A2:F8]
b = Application.Index(a, Evaluate("Row(1:" & UBound(a) & ")"), Array(1, 3, 6))
[M2].Resize(UBound(b), UBound(b, 2)) = b

Somme des colonnes 1,3,5 d'un Array a()

a = [A1:F10].Value
tot = Application.Sum(Application.Index(a, Evaluate("Row(1:" & UBound(a) & ")"), Array(1, 3, 5)))
MsgBox tot

Inversion de 2 colonnes d'un Array

On veut alimenter 2 combobox avec un champ ListeVilleCodePostal qui contient les villes dans la 1ere colonne et les codes postaux dans la seconde.
Pour que le code postal apparaisse en premier dans la seconde liste, nous inversons les 2 colonnes.

b = Application.Index([villeCodePostal], Evaluate("Row(1:" & [villeCodePostal].Rows.Count & ")"), Array(2, 1))
Me.CodePostal.List = b

Saisie intuitive ville+code postal

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 ' Création 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

Fonction Filtre des colonnes d'un Array

Fonction Filtre Array Colonnes

Pour un tableau a() de 30.000 lignes et 3 colonnes extraites dans un tableau b() , on obtient un temps de 0,5 sec. Cette méthode est sensiblement moins performante que la méthode classique (0,22sec )
Filtre Array colonnes

Sub SelectionColonnes()
  a = [A2:D7].Value
  b = FiltreArrayColonnes(a, Array(1, 4, 2))
  [G2].Resize(UBound(b), UBound(b, 2)) = b
End Sub

Function FiltreArrayColonnes(Tbl, ColResult)
  FiltreArrayColonnes = Application.Index(Tbl, Evaluate("Row(1:" & UBound(Tbl) & ")"), ColResult)
End Function

Somme des colonnes 1,3,5 dans le champ B20:F23

a = [B20:F23].Value
tot = Application.Sum(FiltreArrayColonnes(a, Array(1, 3, 5)))
MsgBox tot

Pour transmettre directement 3 colonnes discontinues d'un champ de 30.000 lignes dans un tableau b(), on obtient un temps de 0,25s

Sub SelectionColonnes2()
  Set champ = Range("A2:D7")
  b = FiltreChampColonnes(champ, Array(1, 4, 2))
  [I2].Resize(UBound(b), UBound(b, 2)) = b
End Sub

Function FiltreChampColonnes(Rng, ColResult)
   FiltreChampColonnes = Application.Index(Rng, Evaluate("Row(1:" & Rng.Rows.Count & ")"), ColResult)
End Function

Fonction Filtre des lignes d'un Array en fonction d'une clé

0,20 sec pour 10.000 lignes et 4 colonnes

Fonction Filtre Array lignes clé

Sub SelectionLignesColCle()
  a = [A2:K10000].Value
  b = FiltreArrayLignes(a, 3, "Paris")
  [p2].Resize(UBound(b), UBound(b, 2)) = b
End Sub

Function FiltreArrayLignes(Tbl, col, cle)
  Dim tmp(): ReDim tmp(1 To UBound(Tbl))
  For i = LBound(Tbl) To UBound(Tbl)
    If Tbl(i, col) = cle Then n = n + 1: tmp(n) = i
  Next
  ReDim Preserve tmp(1 To n)
  FiltreArrayLignes = Application.Index(Tbl, Application.Transpose(tmp), _
    Application.Transpose(Evaluate("Row(1:" & UBound(Tbl, 2) & ")")))
End Function

Suppression de lignes d'un Array 2D en fonction d'une clé

Suppime les lignes d'un Array en fonction d'une clé.
Sur l'exemple, nous supprimons les lignes d'un Array a() qui contiennent Issy en colonne 3.

Suppression lignes Array multi-dimensions Clé

Sub SuppessionLignesCle()
  a = [A2:D7].Value
  a = FiltreArraySupLignes(a, 3, "Issy")
  [g2].Resize(UBound(a), UBound(a, 2)) = a
End Sub

Function FiltreArraySupLignes(Tbl, col, cle)
  Dim i,n
  Dim tmp(): ReDim tmp(1 To UBound(Tbl))
  For i = LBound(Tbl) To UBound(Tbl)
    If Tbl(i, col) <> cle Then n = n + 1: tmp(n) = i
  Next
  ReDim Preserve tmp(1 To n)
  FiltreArraySupLignes = Application.Index(Tbl, Application.Transpose(tmp), _
  Application.Transpose(Evaluate("Row(1:" & UBound(Tbl, 2) & ")")))
End Function

Suppression de lignes vides d'un Array 2 dimensions

Suppression lignes vides Array multi-dimensions

Private Sub UserForm_Initialize()
  a = [A2:D7].Value
  Dim tmp(): ReDim tmp(1 To UBound(a))
  For i = LBound(a) To UBound(a) ' sup lignes vides de a(,)
    If a(i, 1) <> "" Then n = n + 1: tmp(n) = i
  Next
  ReDim Preserve tmp(1 To n)
  Me.ListBox1.List = Application.Index(a, Application.Transpose(tmp), _
    Application.Transpose(Evaluate("Row(1:" & UBound(a, 2) & ")")))
End Sub

Avec ArrayList, on supprime les lignes vides du tableau a(,)

Sub SupLignesVidesArray()
  Set AL = CreateObject("System.Collections.ArrayList")
  a = [A2:D7].Value
  For i = LBound(a) To UBound(a)
    If a(i, 1) <> "" Then AL.Add Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4))
  Next i
  a = Application.Transpose(Application.Transpose(AL.ToArray))
  [E2].Resize(UBound(a), UBound(a, 2)) = a
End Sub

Fonction de suppression des doublons d'un array ou champ

Fonction Suppression des doublons d'un Array

Dictionnaire multi-colonnes pour remplacer un Array 2D

En encapsulant un Array 2D dans un dictionnaire, la suppression d'une ligne par une clé devient très simple.

EncapsuleArray

Sub ArrayEncapsuléDico()
  Set d = CreateObject("Scripting.Dictionary")
  a = [A2:C5]
  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")
  For c = 1 To 3
    [F2].Offset(, c - 1).Resize(d.Count, 1) = Application.Index(d.items, , c)
  Next c
End Sub

Recherche d'un élément dans la colonne d'un Array à 1 dimension avec Equiv()

La recherche de la position d'un élément dans un tableau peut se faire avec Equiv(). Dans une boucle, cette recherche n'est pas très rapide.

Sub RecherchePositionElement()
  a = Array("aa", "bb", "cc", "dd", "ee")
  x = "cc"
  p = Application.Match(x, a, 0)
  MsgBox p
End Sub

On obtient 3

Pour une recherche dans un tableau 2D.

aa   11
bb   22
cc   33
dd   44

Sub RecherchePositionElement2()
  a = [{"aa",11;"bb",22;"cc",33;"dd",44}]
  clé= "cc"
  p = Application.Match(clé, Application.Index(a, , 1), 0) ' Recherche dans colonne 1 du tableau a()
  MsgBox a(p, 2)
End Sub

On obtient 33

Recherche d'un élément dans un tableau à 2 dimensions avec VLookup()

Sub RecherchePositionElement()
  a = [{"aa",11;"bb",22;"cc",33;"dd",44}]
  clé = "cc"
  résult = Application.VLookup(clé, a, 2, False)
  MsgBox résult
End Sub

Nombre d'éléments occupés d'un tableau (Array)

Dim a(1 To 10)
a(2) = 45
a(5) = "azerty"
x = Application.CountA(a) ' -->2 ' ne fonctionne pas sur 2010

Sub DernierElement()
  Dim a(1 To 10)
  a(1) = 45
  a(2) = 33
  a(5) = "aaa"
  a(6) = "bbb"
  a(8) = 444
  MsgBox Application.Max(Application.Match("zzz", a, 1), Application.Match(999999, a, 1))
End Sub

Somme/Minimum/Maximum/Moyenne d'un tableau

Sub Somme()
  Dim a(1 To 10)
  a(1) = 5
  a(5) = 2
  a(8) = 10
  total = Application.Sum(a)       ' donne 17
  minimum = Application.Min(a)  ' donne 2
  maxi = Application.Max(a)       ' donne 10
  moy = Application.Average(a)
End Sub

Somme d'une colonne d'un tableau (Array)

Donne la somme de la colonne 2 du tableau a(,)

Sub essai2()
  a = [A1:C5]
  total = Application.Sum(Application.Index(a, , 2))
  MsgBox total
End Sub

Recherche du nom associé au minimum d'un tableau

La colonne A contient des noms et la colonne B contient des nombres

Sub essai()
 Tbl = [A1:B5]
  mini = Application.Min(Tbl)
  pos = Application.Match(mini, Application.Index(Tbl, , 2), 0)
  nom = Tbl(pos, 1)
  MsgBox nom
End Sub

Nombre d'éléments d'un tableau vérifiant un critère

On veut compter combien de fois toto papparaît dans la table Tbl() à 1 dimension.

n = UBound(Filter(Tbl, "toto", vbTextCompare))

Dans la 2eme colonne d'un tableau Tbl(,2) à 2D.

n=Ubound(Filter(Application.Transpose(Application.Index(Tbl, ,2)),"toto"))

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

Indexation Tableau 2D Dico

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

Filtre des colonnes d'un Array

La fonction FiltreArrayCol(tableau,colonnes) sélectionne des colonnes dans un Array .
Sur l'exemple  b = FiltreArrayCol(a, Array(1, 3, 4, 6, 7)) retourne dans b() les colonnes 1, 3, 4, 6, 7

Filtre Array colonnes

Sub FiltreColonnes()
  a = [A2].Resize(4, 20) ' tableau a()
  b = FiltreArrayCol(a, Array(1, 3, 6, 7)) ' on prend les colonnes 1, 3, 6, 7
  [A11].Resize(UBound(b), UBound(b, 2)) = b
End Sub

Function FiltreArrayCol(tableau, ColResult)
  Dim b()
  ReDim b(LBound(tableau) To UBound(tableau), 1 To UBound(ColResult) - LBound(ColResult) + 1)
  decal = 1 - LBound(ColResult)
  For i = LBound(tableau, 1) To UBound(tableau, 1)
    For c = LBound(ColResult) To UBound(ColResult)
      b(i, c + decal) = tableau(i, ColResult(c))
    Next c
  Next i
  FiltreArrayCol = b
End Function

Pour un tableau de 30.000 lignes et 3 colonnes extraites , on obtient un temps de 0,22 sec

Une autre façon d'appeler la fonction

Sub FiltreColonnes2()
  Dim col(1 To 3): col(1) = 1: col(2) = 3: col(3) = 6
  a = [A2].Resize(4, 20) ' tableau a()
  b = FiltreArrayCol(a, col)
  [A11].Resize(UBound(b), UBound(b, 2)) = b
End Sub

Alimentation d'un combobox avec des colonnes discontinues

Filtre Array Colonnes Discontinues

Suppression de lignes dans un Array 2D

La fonction SupArrayLignes(Tableau,colonne,critère) supprime dans un tableau les lignes vérifiant le critère spécifié. Sur l'exemple,  a = FiltreArrayLignes(Tablo, 3, "Issy") supprime dans un tableau a() les lignes de Issy (0,08sec pour un Array de 10.000 lignes et 4 colonnes)

Sup Lignes Array 2D classiqueLignes

Sub SupLignesColCle()
  a = [A2:D7].Value
  a = SupArrayLignes(a, 3, "Issy")
  [G2].Resize(UBound(a), UBound(a, 2)).Value2 = a
End Sub

Function SupArrayLignes(Tbl, col, cle)
  deb = LBound(Tbl): fin = UBound(Tbl)
  cold = LBound(Tbl, 2): colf = UBound(Tbl, 2)
  For i = LBound(Tbl) To UBound(Tbl)
    If Tbl(i, col) <> cle Then n = n + 1
  Next i
  Dim t(): ReDim t(LBound(Tbl) To LBound(Tbl) + n - 1, cold To colf)
  j = LBound(Tbl)
  For i = deb To fin
    If Tbl(i, col) <> cle Then
       For k = cold To colf: t(j, k) = Tbl(i, k): Next k
       j = j + 1
    End If
  Next i
  If n > 0 Then
    SupArrayLignes = t()
  Else
    Dim a(): ReDim a(1 To 1, cold To colf)
    SupArrayLignes = a()
  End If
End Function

Fusion verticale de 2 Arrays 1D

Retourne un tableau 1D avec les 2 Arrays 1D mis bout à bout (0,03 sec pour fusion de 2 tableaux de 10.000 items).

Merge Arrays 1D vertical

Sub mergeTbl1D()
  Set f = Sheets("bd")
  a = Application.Transpose(f.[A1:A10]) ' tableau a(1000) 1D
  b = Application.Transpose(f.[D1:D10]) ' tableau b(1000) 1D
  c = Split(Join(a, ",") & "," & Join(b, ","), ",")
  [K1].Resize(UBound(c) + 1) = Application.Transpose(c)
End Sub

Pour alimenter un combobox avec 2 colonnes discontinues A et D.

Private Sub UserForm_Initialize()
 Set f = Sheets("bd")
 a = Application.Transpose(f.[A1:A10]) ' tableau a(1000) 1D
 b = Application.Transpose(f.[D1:D10]) ' tableau b(1000) 1D
 Me.ComboBox1.List = Split(Join(a, ",") & "," & Join(b, ","), ",")
End Sub

Si la liste doit être triée

Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  a = Application.Transpose(f.[A1:A10]) ' tableau a(1000) 1D
  b = Application.Transpose(f.[D1:D10]) ' tableau b(1000) 1D
  c = Split(Join(a, ",") & "," & Join(b, ","), ",")
  Tri c, LBound(c), UBound(c)
  Me.ComboBox1.List = c
End Sub

Fusion verticale de 2 Arrays 2D

0,03sec pour 2 tableaux 4000x2

Merge Arrays 2D vertical

Sub essaiMergeTbl()
  a = [A1:B10].Value
  b = [A30:B34].Value
  c = MergeArray2DVert(a, b)
  [D1].Resize(UBound(c), UBound(c, 2)) = c
End Sub

Function MergeArray2DVert(a, b)
  maxtab1 = UBound(a)
  Dim Tbl(): ReDim Tbl(1 To UBound(a) + UBound(b), 1 To UBound(a, 2))
  For i = LBound(a) To UBound(a)
    For c = 1 To UBound(a, 2): Tbl(i, c) = a(i, c): Next
  Next i
  For i = 1 To UBound(b)
    For c = 1 To UBound(b, 2): Tbl(maxtab1 + i, c) = b(i, c): Next
  Next i
  MergeArray2DVert = Tbl
End Function

Fusion triée de 3 colonnes pour ComboBox

Form Fusion sans doublons triée de 2 champs

Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  a = Application.Transpose(f.Range("A2:A" & f.[A65000].End(xlUp).Row))
  b = Application.Transpose(f.Range("E2:E" & f.[E65000].End(xlUp).Row))
  c = Application.Transpose(f.Range("K2:K" & f.[K65000].End(xlUp).Row))
  temp = Split(Join(a, ",") & "," & Join(b, ",") & "," & Join(c, ","), ",")
  Tri temp, LBound(temp), UBound(temp)
  Me.ComboBox1.List = temp
End Sub

Pour supprimer les doublons

Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  a = Application.Transpose(f.Range("A2:A" & f.[A65000].End(xlUp).Row))
  b = Application.Transpose(f.Range("E2:E" & f.[E65000].End(xlUp).Row))
  c = Application.Transpose(f.Range("K2:K" & f.[K65000].End(xlUp).Row))
  temp = Split(Join(a, ",") & "," & Join(b, ",") & "," & Join(c, ","), ",")
  Tri temp, LBound(temp), UBound(temp)
  Set d = CreateObject("scripting.dictionary")
  For Each c In temp
     d(c) = ""
  Next c
  Me.ComboBox1.List = d.keys
End Sub

Fusion horizontale de 2 Arrays 2D

La fonction MergeArray(tab1, tab2) retourne dans un tableau 2D la juxtaposition des 2 tableaux spécifiés (1D ou 2D). Les 2 tableaux doivent avoir la même hauteur mais le nombre de colonnes des 2 tableaux peut être différent .

Merge Arrays 2D horizontal

Sub EssaiMergeArray2D()
  a = [A2:D5] ' tableau 2D
  b = [F2:H5] ' tableau 2D
  c = MergeArrayHoriz(a, b)
  [m2].Resize(UBound(c), UBound(c, 2)) = c
End Sub


Function MergeArrayHoriz(Tab1, Tab2)
  On Error Resume Next
  ktab1 = True: col1 = UBound(Tab1, 2): If Err > 0 Then col1 = 1: ktab1 = False
  Err = 0: ktab2 = True: col2 = UBound(Tab2, 2): If Err > 0 Then col2 = 1: ktab2 = False
  On Error GoTo 0
  Dim b(): ReDim b(1 To UBound(Tab1), 1 To col1 + col2)
  For lg = LBound(Tab1, 1) To UBound(Tab1)
    For c = 1 To col1
      If ktab1 = True Then b(lg, c) = Tab1(lg, c) Else b(lg, c) = Tab1(lg)
    Next c
  Next lg
  k = col1
  For lg = LBound(Tab2, 1) To UBound(Tab2)
    For c = 1 To col2
      If ktab2 = True Then b(lg, c + k) = Tab2(lg, c) Else b(lg, c + k) = Tab2(lg)
    Next c
  Next lg
  MergeArrayHoriz = b
End Function

On peut emboiter plusieurs fonctions

Sub EssaiMergeArray2()
  a = [A1].Resize(5, 1)    ' tableau a(5,1) 2D
  b = [c1].Resize(5, 1)    ' tableau b(5,1)
  c = [e1].Resize(5, 1)    ' tableau c(5,1)
  d = MergeArrayHoriz(MergeArrayHoriz(a, b), c)
  [m1].Resize(UBound(d), UBound(d, 2)) = d   ' tableau d(5,3)
End Sub

Comparaison de 2 Arrays: fusion de 2 Arrays , communs de 2 Arrays et différence de 2 Arrays

Les fonctions matricielles Fusion() , Communs(), Diff() fonctionnent aussi bien sur des tableaux que sur des champs. On récupère un tableau 2D (1 To N,1 To 1).

Fusion de 2 Arrays, Communs, Différence

Sub EssaiCommuns()
  a = [tab3].Value
  b = [tab2].Value
  c = Communs(a, b)
  [A20:A22] = c
End Sub

Sub EssaiFusion()
  a = [tab1].Value
  b = [tab2].Value
  c = [tab3].Value
  d = Fusion(a, b, c)
  [A20].Resize(UBound(d)) = d
End Sub

Sub EssaiDiff()
  a = [tab1].Value
  b = [tab2].Value
  c = Diff(b, a)
  [c20].Resize(UBound(c)) = c
End Sub

On veut les éléments qui sont présents au moins 2 fois dans 3 tableaux.

Sub essaiFusionCommuns()
  a = [tab1].Value
  b = [tab2].Value
  c = [tab3].Value
  d = Fusion(Communs(a, b), Communs(b, c), Communs(a, c))
  [d20].Resize(UBound(d)) = d
End Sub

On peut alimenter un ComboBox trié avec 2 champs nommés Tab1 et Tab2

Fusion de 2 Arrays pour Combobox trié

Private Sub UserForm_Initialize()
    Me.ComboBox1.List = Fusion(Range("tab1"), Range("tab2"))
End sub

Fonction SansDoublonsTrié d'un tableau(Array)

Cette fonction retourne un tableau sans doublons trié. Elle est compatible MAC.

Fonction Sans Doublons Trié

Sub Essai()
  Dim a(), b()
  a = Application.Transpose(Range("A2:A" & [A65000].End(xlUp).Row).Value)
  b = SansDoublonsTrié(a())
  [k2].Resize(UBound(b)).Value = b
End Sub

Function SansDoublonsTrié(a)
  Call Tri(a, LBound(a), UBound(a))
  Dim b(): ReDim b(1 To UBound(a))
  i = 1: j = 0
  Do While i <= UBound(a)
    j = j + 1: b(j) = a(i)
    Do While a(i) = b(j)
      i = i + 1: If i > UBound(a) Then Exit Do
    Loop
  Loop
  ReDim Preserve b(1 To j)
  SansDoublonsTrié = Application.Transpose(b)
End Function

Avec Dictionary, cette fonction devient

Function SansDoublonsTrié(a)
   Set d = CreateObject("Scripting.Dictionary")
   For Each c In a
      d(c) = ""
   Next c
   b = d.keys
   Call Tri(b, LBound(b), UBound(b))
   SansDoublonsTrié = Application.Transpose(b)
End Function

Pour alimenter un combobox de formulaire

Sans doublons trié

Private Sub UserForm_Initialize()
  Me.ComboBox1.List = SansDoublonsTrié(Application.Transpose(Range("A2:A" &      [A65000].End(xlUp).Row)))
End Sub

Fonction de Filtre d'une BD avec 1 ou 2 critères

Sur l'exemple, nous filtrons les lignes d'une BD en ne prenant que les lignes concernant que le compte banque.

Sélectionner A3:E100
=FiltreBD(BD; 6; A1; {1;2;3;4;5})
Valider avec maj+ctrl+entrée

FiltreBD
FiltreBD2
Filtre BD Villes Département

Function FiltreBD(BD As Range, colCrit1, critere1, ColResult, Optional colcrit2, Optional critere2, Optional ColTri)
  a = BD
  k = 1
  Dim b(): ReDim b(LBound(a) To Application.Caller.Rows.Count, 1 To UBound(ColResult) - LBound(ColResult) + 1)
  If IsMissing(colcrit2) Then colcrit2 = colCrit1: critere2 = critere1
    For i = LBound(a, 1) To UBound(a, 1)
     If UCase(a(i, colCrit1)) = UCase(critere1) And UCase(a(i, colcrit2)) = UCase(critere2) Then
       For c = LBound(ColResult) To UBound(ColResult)
         col = ColResult(c, 1)
         b(k, c) = a(i, col)
       Next c
       k = k + 1
     End If
   Next i
   'If IsMissing(ColTri) Then ColTri = 1
   'Call TriCol(b, LBound(b), k - 1, ColTri)
  FiltreBD = b
End Function

Sous total tableau trié

Sous Total Tableau 1D

Sub SousTotal()
  [A1].Sort Key1:=[A1], Order1:=xlAscending, Header:=xlYes
  a = Range("A2:B" & [a65000].End(xlUp).Row)
  Dim b(): ReDim b(1 To UBound(a), 1 To 2)
  i = 1: j = 0
  Do While i <= UBound(a)
    j = j + 1: b(j, 1) = a(i, 1)
    Do While a(i, 1) = b(j, 1)
      b(j, 2) = b(j, 2) + a(i, 2)
      i = i + 1: If i > UBound(a) Then Exit Do
    Loop
  Loop
  [E2].Resize(UBound(b), UBound(b, 2)) = b
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 avec indexation du tableau par dictionnaire

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

Sous Total 2col
Synthèse tableau

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

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

ou

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

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

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

Autre exemple

On veut regrouper suivant PartNumber et totaliser la colonne 1. La table b() est indexée par le dictionnaire pour permettre un accès plus rapide à chaque ligne de la table b().

Sous Total Tableau 2D
Sous Total Tableau 2D 2
Sous Total Tableau 2D 3

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

Si la table a() est triée

Sub SousTotal()
  Set champ = Range("A2:D" & [a65000].End(xlUp).Row)
  champ.Sort key1:=[b2]
  a = champ.Value
  Dim b(): ReDim b(1 To UBound(a), 1 To UBound(a, 2))
  i = 1: j = 0
  Do While i <= UBound(a)
   j = j + 1: For k = 2 To 4: b(j, k) = a(i, k): Next k
   Do While a(i, 2) = b(j, 2)
     b(j, 1) = b(j, 1) + a(i, 1)
     i = i + 1: If i > UBound(a) Then Exit Do
    Loop
  Loop
  [A1:D1].Copy [h1]
  [h2].Resize(UBound(b), UBound(b, 2)) = b
End Sub

Fusion de 2 tableaux

Fusion_2014_2015

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

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

RegroupeSousTotal
RegroupeSousTotal Plusieurs Colonnes Plusieurs champs
RegroupeSousTotal Plusieurs Colonnes Plusieurs champs clé 2 colonnes
RegroupeSousTotal Plusieurs Colonnes Plusieurs champs 2
RegroupeSousTotal Plusieurs Colonnes Plusieurs Champs 3 Dico

Sub RegroupeCumul()
  Set d1 = CreateObject("Scripting.Dictionary")
  Set f1 = Sheets("données")
  ncol = f1.[a1].CurrentRegion.Columns.Count
  Dim Tbl()
  ReDim Tbl(1 To 1000, 1 To ncol)
  ligT = 1
  MaxLigT = ligT
  a = f1.[a1].CurrentRegion
  For ligne = 2 To UBound(a)
    crit = a(ligne, 1)
    If d1.exists(crit) Then ligT = d1(crit) Else d1(crit) = MaxLigT: ligT = MaxLigT: MaxLigT = MaxLigT + 1
      For col = 2 To ncol
        If a(ligne, col) <> "" Then Tbl(ligT, col - 1) = Tbl(ligT, col - 1) + Val(a(ligne, col))
      Next col
   Next ligne
   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) = Tbl
End Sub

Autre méthode de sous-total avec dictionnaire multicolonnes

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

Sous total multi-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

Suppression des doublons sur colonne A et B et Totalisation

Sup Doublons ColAColBTotal

Sub SupDoublonsColAColBV3()
  Application.ScreenUpdating = False
  Set f1 = Sheets("BD")
  a = f1.Range("A1").CurrentRegion.Value
  Set mondico = CreateObject("Scripting.Dictionary")
  Set mondico2 = CreateObject("Scripting.Dictionary")
  Set mondico3 = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(a)
      temp = a(i, 1) & " / " & a(i, 2)
      mondico(temp) = mondico(temp) + a(i, UBound(a, 2))
      mondico2(temp) = a(i, 1)
      mondico3(temp) = a(i, 2)
   Next
   f1.[G1].Resize(mondico.Count) = Application.Transpose(mondico2.items)
   f1.[H1].Resize(mondico.Count) = Application.Transpose(mondico3.items)
   f1.[I1].Resize(mondico.Count) = Application.Transpose(mondico.items)
End Sub

Statistiques 2 critères

Stat2CritèresTotaux

Sub Stat2D()
  Set d1 = CreateObject("Scripting.Dictionary")
  Set d2 = CreateObject("Scripting.Dictionary")
  Dim a(1 To 100, 1 To 100)
  Dim t1(1 To 100)
  Dim t2(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
    a(lig, col) = a(lig, col) + c.Offset(, 2)
    t1(lig) = t1(lig) + c.Offset(, 2)
    t2(col) = t2(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) = a
  [f2].Offset(d1.Count, 1).Resize(, d2.Count) = t2
  [g2].Offset(, d2.Count).Resize(d1.Count) = Application.Transpose(t1)
End Sub

Avec des fonctions standards (cf programme)

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

Autre exemple

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

Stat 2 CritèresTotaux 2

Position d'un élément dans un Array

On recherche la position de Martin dans l'Array Tbl(,). On peut également utiliser Application.Match (qui est lent)

Nom       Salaire     Age
Dupont    2400         23
Durand    1800         28
Martin      3000         30
Zoé         2600         27

Sub EssaiPosTbl()
   Set f = Sheets("feuil1")
   Tbl = f.Range("A2:C" & f.Range("A65000").End(xlUp).Row).Value
   MsgBox PosTbl(Tbl, 1, "Martin")
End Sub

Function PosTbl(Tbl, colonne, Valeur)
  For i = LBound(Tbl) To UBound(Tbl)
    If Tbl(i, colonne) = Valeur Then PosTbl = i: Exit Function
  Next i
  PosTbl = 0
End Function

Valeur associée dans un Array

On recherche dans le tableau Tbl(,) la valeur associée à 3000 (colonne 2) dans la colonne 3 (30)
On peut également utiliser Application.Match (qui est lent) et Application.Index. Si la colonne d'entrée est la première colonne, on peut utiliser Application.Vlookup.

Sub EssaiValAssocié()
  Set f = Sheets("feuil1")
  Tbl = f.Range("A2:C" & f.Range("A65000").End(xlUp).Row).Value
  plusgrand = Application.Max(Application.Index(Tbl, , 2))
  MsgBox ValAssocié(Tbl, 2, plusgrand, 3)
End Sub

Function ValAssocié(Tbl, colEntrée, Valentrée, Colsortie)
  For i = LBound(Tbl) To UBound(Tbl)
    If Tbl(i, colEntrée) = Valentrée Then ValAssocié = Tbl(i, Colsortie): Exit Function
  Next i
  ValAssocié = 0
End Function

Tri d’un tableau (Array) à 1 dimension

-Avec Quick-Sort, le temps de tri de 10.000 nombres aléatoires est de 0,04 secondes. Le temps de tri est proportionnel au nombre d'éléments n.
-Avec Bubble-Sort, le temps de tri de 10.000 nombres aléatoires est de 15 secondes. Le temps de tri est proportionnel au carré du nombre d'éléments (n*n). Ce tri est utilisé essentiellement dans l'enseignement à des fins pédagogiques (à éviter).

Comparaison Tris QuickSort Shell Shell/Metzner

TriDivers

Le principe du tri Quick-sort est le suivant
On répartit la suite de nombres à trier de telle sorte que tous les éléments inférieurs à un élément de référence (36 sur l'exemple) soient à gauche de celui-ci et que tous ceux qui lui sont supérieurs à sa droite.

[70 61 16 48 29 18 59 36 3 70 3 22 39 30 58 10] <- Avant
                                  ¦
             Elément médian de référence
                             ¦
[3 30 16 22 29 18] 36 [70 59 48 39 59 61 58 70] <- Après

               ¦                              ¦
Eléments<36                   Eléments>36

Tous les éléments de l'ensemble de droite sont supérieurs à ceux de l'ensemble de gauche. En procédant de la même façon sur les 2 sous-ensembles générés,on obtient 4 sous-ensembles ordonnés entre eux. Lorsque la taille des ensembles devient égale à 1,les nombres sont triés.

Choix de l'élément de référence
Pour obtenir des sous-ensembles de tailles équilibrées, il faut que l'élément de référence ne soit ni trop petit, ni trop grand.
La méthode classique consiste à choisir l'élément de référence parmi 3 éléments:Ceux de gauche, du milieu et de droite.
Nous observons qu'en choisissant l'élément de référence au milieu de la liste à traiter, le temps de tri est le même.

Remarques
-Si la liste est déjà triée, le temps de tri n'augmente pas lorsque l'élément de référence est choisi au milieu, ce qui n'est pas le cas lorsqu'il est choisi à gauche.
-Le programme proposé est récursif.

Sub TriQuick()
  n = 10000 ' 0,625 s
  Dim temp() As Double
  ReDim temp(1 To n)
  For i = 1 To n
    temp(i) = Rnd * 100000
  Next i
  Tri temp, 1, n
  [A1].Resize(n) = Application.Transpose(temp)
End Sub

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

Pour un tri décroissant

Do While a(g, colTri) > ref: g = g + 1: Loop
Do While ref > a(d, colTri): d = d - 1: Loop

Tri Array Shell

Tri Shell
Tri Shell Multi critères David84

Sub essaiTri()
  n = 10000
  Dim a(): ReDim a(1 To n )
  For i = LBound(a) To UBound(a): a(i) = "Nom" & Format(n - i +1, "00000"): Next i
  ShellSort a
  [A2].Resize(n) = Application.Transpose(a)
End Sub

Sub ShellSort(list)
  'Dave Braden's (code modifié David84 pour LowIndex=0)
  Dim i As Long, j As Long, inc As Long
  Dim var As Variant, LowIndex As Integer, HiIndex As Long
  LowIndex = LBound(list): HiIndex = UBound(list)
  inc = LowIndex
  Do While inc <= HiIndex - LowIndex: inc = 3 * inc + 1: Loop
  Do
    inc = inc \ 3
    For i = inc + LowIndex To HiIndex
      var = list(i)
      j = i
      Do While list(j - inc) > var
        list(j) = list(j - inc)
        j = j - inc
        If j <= inc + LowIndex - 1 Then Exit Do
      Loop
      list(j) = var
    Next
  Loop While inc > 1
End Sub

Tri Array Shell/Metzner

0,15 s pour 10.000 items

Tri Shell Metzner
Tri Shell Metzner Croissant Décroissant

Sub essaiTri()
  n = 10000
  Dim a(): ReDim a(1 To n)
  For i = LBound(a) To UBound(a): a(i) = "Nom" & Format(n - i + 1, "00000"): Next i
  TriShellMetzner a
  [A2].Resize(n) = Application.Transpose(a)
End Sub

Sub TriShellMetzner(a())
  Dim inc As Long, i As Long, j As Long, n As Long
  Dim inv As Boolean, tmp As Variant
  n = UBound(a)
  inc = n \ 2
  Do While inc <> 0
    For i = 1 To n - inc
       j = i
       inv = True
       Do While j > Lbound(a)-1 And inv
         inv = False
         If a(j) > a(j + inc) Then
            tmp = a(j): a(j) = a(j + inc): a(j + inc) = tmp: inv = True
            j = j - inc
         End If
       Loop
    Next i
    inc = inc \ 2
  Loop
End Sub

Tri Array QuickSort croissant/décroissant

Tri Croissant Décroissant

Option Compare Text
Sub Tri()
  Dim a()
  a = [A2:B6].Value
  '-- tri nom croissant
  Quick a(), LBound(a), UBound(a), 1, True
  [D2:E6].Value2 = a
  '-- tri salaire décroissant
  Quick a(), LBound(a), UBound(a), 2, False
  [g2:h6].Value2 = a
End Sub

Sub Quick(a(), gauc, droi, col, ordre) ' Quick sort
  ref = a((gauc + droi) \ 2, col)
  g = gauc: d = droi
  Do
    If ordre Then
      Do While a(g, col) < ref: g = g + 1: Loop
      Do While ref < a(d, col): d = d - 1: Loop
    Else
      Do While a(g, col) > ref: g = g + 1: Loop
      Do While ref > a(d, col): d = d - 1: Loop
    End If
    If g <= d Then
      For i = LBound(a, 2) To UBound(a, 2)
        temp = a(g, i): a(g, i) = a(d, i): a(d, i) = temp
      Next i
      g = g + 1: d = d - 1
    End If
  Loop While g <= d
  If g < droi Then Call Quick(a, g, droi, col, ordre)
  If gauc < d Then Call Quick(a, gauc, d, col, ordre)
End Sub 

Fonction liste triée

Cette fonction personalisée matricielle permet d'obtenir une liste triée . Elle est beaucoup +rapide qu'avec une formule matricielle:

-Matricielle :  200 éléments --> 2sec
-VBA:              10.000 éléments --> 0,15 sec

Fonction liste triée
Fonction liste sans vides
Fonction liste triée conditionnelle

Function ListeTriée(champ As Range)
  Application.Volatile
  temp = champ.Value
  Dim b()
  ReDim b(1 To Application.Caller.Rows.Count)
  n = 0
  For Each c In temp
     If c <> "" Then
         n = n + 1
         b(n) = c
     End If
  Next
 Tri b, 1, n
  ListeTriée = Application.Transpose(b)
End Function

Tri d'un tableau (Array) à 2 dimensions

Le choix de la colonne de tri se fait avec le paramètre ColTri de la procédure Tri().
Pour des tableaux avec beaucoup de lignes et de colonnes, il est préférable d'utiliser un tri indexé.

Tri Tableau 2D
Tri Tableau 2D Fonction Standard

Remarque: Le but de ce programme n'est pas de remplacer le tri de données du tableur avec Excel (Champ.Sort) mais de trier des données déjà présentes dans un Array.

Option Compare Text
Sub TriTableau2D()
  Dim a()
  a = [A2:D6].Value                                                      ' Tableau 2D
  Tri a(), 1, LBound(a, 1), UBound(a, 1)
  [F2].Resize(UBound(a, 1), UBound(a, 2)).Value2 = a     ' Value2 pour les dates Laeticia90
End Sub

Sub Tri(a(), ColTri, gauc, droi) ' Quick sort
  ref = a((gauc + droi) \ 2, ColTri)
  g = gauc: d = droi
  Do
    Do While a(g, ColTri) < ref: g = g + 1: Loop
    Do While ref < a(d, ColTri): d = d - 1: Loop
    If g <= d Then
       For k = LBound(a, 2) To UBound(a, 2)
         temp = a(g, k): a(g, k) = a(d, k): a(d, k) = temp
       Next k
       g = g + 1: d = d - 1
    End If
  Loop While g <= d
  If g < droi Then Call Tri(a, ColTri, g, droi)
  If gauc < d Then Call Tri(a, ColTri, gauc, d)
End Sub

Tri avec vides dans le tableau

Tri Tableau 2D Avec Vides

Pour supprimer les vides nous cherchons la position du premier non vide du tableau avec:

 p = Application.Match("*", Application.Index(a, , 1), 0)

Sub TriTableau2D()
  Dim a()
  a = Range("a2:e" & [A65000].End(xlUp).Row).Value ' Tableau 2D
  Tri a(), 1, LBound(a, 1), UBound(a, 1)
  p = Application.Match("*", Application.Index(a, , 1), 0)
  Dim c()
  ReDim c(1 To UBound(a) - p + 1, 1 To UBound(a, 2))
  For i = p To UBound(a)
    For k = LBound(a, 2) To UBound(a, 2): c(i - p + 1, k) = a(i, k): Next k
  Next i
  Erase a
  a = c
  [G2].Resize(UBound(c, 1), UBound(c, 2)).Value2 = a
End Sub

Tri Multi-critères d'un tableau (Array) à 2 dimensions

Le tri par nom+salaire de 5.000 lignes se fait en 0,15 sec.
Pour des tableaux avec beaucoup de lignes et de colonnes, il est préférable d'utiliser un tri indexé.

Tri Tableau 2D 2Critères
Tri Tableau 2D 2Critères Bis
Tri Tableau 2D 2Struct
Tri Shell Multi-critères David84

Option Compare Text
Sub TriTableau2D()
  Dim a()
  a = [A2:C7].Value ' Tableau 2D
  Tri a(), LBound(a, 1), UBound(a, 1)
  [F2].Resize(UBound(a, 1), UBound(a, 2)).Value2 = a
End Sub

Sub Tri(a(), gauc, droi) ' Quick sort
  ref = a((gauc + droi) \ 2, 1) & Format(a((gauc + droi) \ 2, 3), "0000")
  g = gauc: d = droi
  Do
    Do While a(g, 1) & Format(a(g, 3), "0000") < ref: g = g + 1: Loop
    Do While ref < a(d, 1) & Format(a(d, 3), "0000"): d = d - 1: Loop
      If g <= d Then
        For k = LBound(a, 2) To UBound(a, 2)
           temp = a(g, k): a(g, k) = a(d, k): a(d, k) = temp
        Next k
        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

Avec des fonctions standards (cf programme)

Tri Tableau 2D 2 Critères Fonctions Standards

Sub TriNomSalaire()
  Tablo = [A2:C7]
  TriTabMult Tablo, 1, 3 ' Tri par nom+salaire
  [F2:H7].Value2 = Tablo
End Sub

Tri Multi-critères d'un tableau (Array) à 2 dimensions avec index

Dans le progamme de tri, au lieu d'inverser toutes les colonnes on inverse seulement les clés de tri
et l'index. Pour 10 colonnes par exemple, le temps de tri est divisé par 3.

Le tri par nom+salaire de 5.000 lignes se fait en 0,07 sec.

Tri Tableau 2D 2 Critères Index
Tri ListBox Multi Critères
Tri ListBox Multi Critères NomPrénom
Form Tri Alpha ou Num
Form Tri Alpha ou Num multi-critères

Option Compare Text
Sub TriTableau2D2Critères()
  Dim clé() As String, index() As Long
  a = [A2:C7].Value                      ' Champ [A2:C7] dans tableau a() 
  Dim b()
  ReDim b(LBound(a) To UBound(a), LBound(a, 2) To UBound(a, 2))
  ReDim clé(LBound(a) To UBound(a, 1))
  ReDim index(LBound(a) To UBound(a, 1))
  For i = LBound(a) To UBound(a, 1)
    clé(i) = a(i, 1) & Format(a(i, 3), "0000"): index(i) = i
  Next i
  Tri clé(), index(), LBound(a), UBound(clé)
  For lig = LBound(clé) To UBound(clé)
     For col = LBound(a, 2) To UBound(a, 2): b(lig, col) = a(index(lig), col): Next col
  Next lig
  [G2].Resize(UBound(b), UBound(b, 2)).Value2 = b     ' Tableau trié dans le tableur
End Sub

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

Autre exemple

On veut alimenter 2 combobox: Choix par ville et choix par code postal.
La BDD est triée par ville. Il faut donc la trier par code postal pour alimenter le combobox CodePostal.
Le tri indexé d'un Array de 36.000 lignes et 10 colonnes est 3 fois plus rapide que l'inversion de toutes les colonnes (0,4 sec au lieu de 1,2 sec).

Tri Indexé Code postal

Dim f, ListeVille()
Private Sub UserForm_Initialize()
  '--villes +codes postaux
  ListeVille = Range("bdd").Value
  Me.ComboVille.List = ListeVille
  '-- inversion des colonnes 1,2 pour un tri par code postal
  b = Application.index([bdd], Evaluate("Row(1:" & [bdd].Rows.Count & ")"), Array(2, 1, 3, 4, 5, 6, 7, 8, 9, 10))
  TriTableauIndex b ' + rapide
  Me.CodePostal.List = b
End Sub

Sub TriTableauIndex(b)
  Dim Tmp(): ReDim Tmp(LBound(b) To UBound(b), LBound(b, 2) To UBound(b, 2))
  Dim clé() As String: ReDim clé(LBound(b) To UBound(b))
  Dim index() As Long: ReDim index(LBound(b) To UBound(b, 1))
  For i = LBound(b) To UBound(b)
    clé(i) = b(i, 1): index(i) = i
  Next i
  TriIndex clé(), index(), LBound(b), UBound(clé)
  For lig = LBound(clé) To UBound(clé)
     For col = LBound(b, 2) To UBound(b, 2): Tmp(lig, col) = b(index(lig), col): Next col
  Next lig
  b = Tmp
End Sub

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

Tri multicritères avec SortedList

Tri Tableau 2D 2 Critères Index SortedList

Sub TriTableau2DNomSalaire()
  Dim clé() As String, index() As Long
  a = [A2:E9].Value
  Dim b()
  ReDim b(LBound(a) To UBound(a), LBound(a, 2) To UBound(a, 2))
  Set oSortedList = CreateObject("System.Collections.Sortedlist")
  For i = LBound(a) To UBound(a)
    oSortedList.Add a(i, 1) & Format(a(i, 3), "0000"), i
  Next i
  For lig = LBound(a) To UBound(a)
    For col = LBound(a, 2) To UBound(a, 2)
       b(lig, col) = a(oSortedList.GetByIndex(lig - 1), col)
    Next col
  Next lig
  [H2].Resize(UBound(b), UBound(b, 2)).Value2 = b
End Sub

SortedList n'accepte pas les doublons. Pour effectuer un tri avec SortedList s'il y a des doublons (la ville par exemple), nous créons des clés uniques avec :

 oSortedList.Add a(i, 4) & i, i

Sub TriTableauVilleSortedList()
  Dim clé() As String, index() As Long
  a = [A2:E9].Value
  Dim b()
  ReDim b(LBound(a) To UBound(a), LBound(a, 2) To UBound(a, 2))
  Set oSortedList = CreateObject("System.Collections.Sortedlist")
  For i = LBound(a) To UBound(a)
    oSortedList.Add a(i, 4) & i, i
  Next i
  For lig = LBound(a) To UBound(a)
    For col = LBound(a, 2) To UBound(a, 2)
      b(lig, col) = a(oSortedList.GetByIndex(lig - 1), col)
   Next col
  Next lig
  [G2].Resize(UBound(b), UBound(b, 2)).Value2 = b
End Sub

Pour unListBox trié par nom&prénom

Private Sub UserForm_Initialize()
  Set f = Sheets("bd2")
  a = f.Range("A2:E" & f.[A65000].End(xlUp).Row).Value
  ReDim b(LBound(a) To UBound(a), LBound(a, 2) To UBound(a, 2))
  Set SL = CreateObject("System.Collections.Sortedlist")
  For i = LBound(a) To UBound(a)
    SL.Add a(i, 1) & a(i, 2), Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4), a(i, 5))
  Next i
  Set AL = CreateObject("System.Collections.Arraylist")
  AL.AddRange SL.Values
  Me.ListBox1.Column = Application.Transpose(AL.toarray)
End Sub

Tri de ListBox croissant ou décroissant

Form Tri ListBox Croissant_Décroissant
Form Tri ListBox Alpha ou Num
Form Tri ListBox Multi Colonnnes Croissant/Décroissant
Form Tri ListBox Multi-colonnes Alpha ou Num multi-critères

Module de classe Tableau

Cette classe Tableau:

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

Classe Tableau

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

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

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

Module de classe Base de données

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

ClasseBD Dictionary

Tri d'un Array 1 dimension à l'aide du tableur

Tri Array AvecTableur

Sub TriTableau1D()
  Dim a(1 To 5) ' 5 lignes
  '------ remplissage du tableau a()
  a(1) = "dd"
  a(2) = "bb"
  a(3) = "cc"
  a(4) = "aa"
  a(5) = "ee"
  '------ transfert tableau a() dans le tableur
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Sheets.Add
  [A1].Resize(UBound(a)) = Application.Transpose(a) ' transfert tableur
  [A1].CurrentRegion.Sort key1:=[A1]
  b = [A1].CurrentRegion ' transfert champ --> b(,)
  ActiveSheet.Delete
  For i = LBound(b) To UBound(b)
    a(i) = b(i, 1)
  Next i
  '[A1].Resize(UBound(a)) = Application.Transpose(a) ' vérification
End Sub

Tri d'un Array 2 dimensions à l'aide du tableur

Sub TriTableau2D()
  Dim a(1 To 5, 1 To 2) ' 5 lignes, 2 colonnes
  '------ remplissage du tableau a()
  a(1, 1) = "dd"
  a(2, 1) = "bb"
  a(3, 1) = "cc"
  a(4, 1) = "aa"
  a(5, 1) = "ee"
  a(1, 2) = 11
  a(2, 2) = 12
  a(3, 2) = 13
  a(4, 2) = 14
  a(5, 2) = 15
  '------ transfert tableau a() dans le tableur
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Sheets.Add
  [A1].Resize(UBound(a, 1), UBound(a, 2)) = a ' transfert tableur
  [A1].CurrentRegion.Sort key1:=[A1]
  b = [A1].CurrentRegion ' transfert champ --> b(,)
  ActiveSheet.Delete
  For i = LBound(b) To UBound(b)
     For j = LBound(b, 2) To UBound(b, 2)
       a(i, j) = b(i, j)
    Next j
  Next i
  '[A1].Resize(UBound(a, 1), UBound(a, 2)) = a   ' Vérification
End Sub

Tri d'un tableau (Array) de structures

Tri Tableau Structure
Tri Tableau Structure multi-critères
Tri Tableau Structure multi-critères 2

Type Personne
  Nom As String
  age As Integer
End Type

Sub essai()
  Dim a(1 To 5) As Personne
  Dim temp As Personne
  a(1).Nom = "Dupont": a(1).age = 40
  a(2).Nom = "Balu": a(2).age = 30
  a(3).Nom = "Charlie": a(3).age = 20
  a(4).Nom = "Durand": a(4).age = 25
  a(5).Nom = "Campas": a(5).age = 35
  '---- Tri Bubble
  For i = 1 To 5
    For j = i To 5
      If a(j).Nom < a(i).Nom Then
        temp = a(j): a(j) = a(i): a(i) = temp
      End If
    Next j
  Next i
  '-- transfert feuille
  For i = 1 To 5
    Cells(i + 1, 1) = a(i).Nom
    Cells(i + 1, 2) = a(i).age
  Next i
End Sub

ou

Tri Tableau Structure2

Type Personne
  T(1 To 3)
End Type

Sub essai()
  n = 5
  Dim a() As Personne: ReDim a(1 To n)
  Dim temp As Personne
  For i = 1 To n
     For col = 1 To 3
        a(i).T(col) = Cells(i + 1, col)
     Next col
  Next i
  '---- Tri Bubble
  For i = 1 To n
  For j = i To n
     If a(j).T(1) < a(i).T(1) Then
        temp = a(j): a(j) = a(i): a(i) = temp
     End If
   Next j
  Next i
  '-- transfert feuille
  For i = 1 To n
    For col = 1 To 3
      Cells(i + 1, col + 5) = a(i).T(col)
    Next col
  Next i
End Sub

Recherche rapide dans un tableau (Array) de structures

Type Personne
Nom As String
age As Integer
End Type

Sub essai()
  Set d = CreateObject("Scripting.Dictionary")
  n = 5
  Dim a() As Personne: ReDim a(1 To n)
  Dim temp As Personne
  a(1).Nom = "Dupont": a(1).age = 40
  a(2).Nom = "Balu": a(2).age = 30
  a(3).Nom = "Charlie": a(3).age = 20
  a(4).Nom = "Durand": a(4).age = 25
  a(5).Nom = "Campas": a(5).age = 35
  '--- indexation de la table avec un dico
  For i = 1 To n
    d(a(i).Nom) = i
  Next i
  '---- Recherche
  NomCherché = "Balu"
  MsgBox a(d(NomCherché)).age
End Sub

Tri avec module de classe

Classe BD Dictionary

Tri multi-zones

Tri Multi-zones

Les champs sont nommés Nom et Salaire

Sub TriMC()
  Dim temp(), temp2()
  ReDim temp(Range("Nom").Count)
  ReDim temp2(Range("Nom").Count)
  lig = 0
  For i = 1 To Range("Nom").Areas.Count
    For j = 1 To Range("Nom").Areas(i).Count
      lig = lig + 1
      temp(lig) = Range("Nom").Areas(i)(j)
      temp2(lig) = Range("Salaire").Areas(i)(j)
    Next j
  Next i
  Call Tri2(temp, temp2, 1, lig)
  lig = 0
  For i = 1 To Range("Nom").Areas.Count
    For j = 1 To Range("Nom").Areas(i).Count
      lig = lig + 1
      Range("Nom").Areas(i)(j) = temp(lig)
      Range("Salaire").Areas(i)(j) = temp2(lig)
    Next j
  Next i
End Sub

Sub Tri2(a, b, 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
      tmp2 = b(g): b(g) = b(d): b(d) = tmp2
      g = g + 1: d = d - 1
    End If
  Loop While g <= d
  If g < droi Then Call Tri2(a, b, g, droi)
  If gauc < d Then Call Tri2(a, b, gauc, d)
End Sub

Fonction liste sans doublons triée

Cette fonction personalisée matricielle donne une liste triée sans doublons.

Dans le tableur

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

Fonction Sans Doublons Triée
Fonction Tri
Fonction Sans Vides
Fonction Triée conditionnelle
Fonction Triée conditionnelle Sans doublons

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

Fonction de tri multizones

FonctionSansDoublonsTriéeMultiZones

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

Fonction sansDoublons2col()

Cette fonction supprime les doublons d'un tableau 2 colonnes.

Fonction SansDoublons2Col

Sub Essai()
  Tblclé = Range("A2:B" & [A65000].End(xlUp).Row).Value ' Nom+Prénom
  temp = sansdoublons2Col(Tblclé)
  [D2].Resize(UBound(temp), 2) = temp
End Sub

Function sansdoublons2Col(a)
  Set d1 = CreateObject("scripting.dictionary")
  Dim b(): ReDim b(1 To 2, 1 To UBound(a))
  ligne = 0
  For i = LBound(a) To UBound(a)
    tmp = a(i, 1) & a(i, 2)
    If Not d1.exists(tmp) Then
      d1(tmp) = ""
      ligne = ligne + 1: b(1, ligne) = a(i, 1): b(2, ligne) = a(i, 2)
   End If
  Next i
  ReDim Preserve b(1 To 2, 1 To ligne)
  sansdoublons2Col = Application.Transpose(b)
End Function

Liste des feuilles dans l'ordre alphabétique

Alimente un menu déroulant avec la liste de feuilles du classeur dans l’ordre alpabétique.

ChoixFeuille

Private Sub UserForm_Initialize()
  Dim temp()
  n = Sheets.Count
  ReDim temp(1 To n)
  For i = 1 To n
    temp(i) = Sheets(i).Name
  Next i
  Call tri(temp, 1, n)
  Me.ComboBox1.List = temp
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

Private Sub ComboBox1_Click()
  temp = Me.ComboBox1
  Sheets(temp).Select
End Sub

ArrayList

C'est un objet de System.Collections.ArrayList. N'est pas disponible sur toutes les versions.
Il peut être remplacé par Dictionary (plus rapide).
L'ArrayList une colonne peut être trié avec Sort.

ArrayList

Add item                 Ajoute un item dans ArrayList
Insert indice,item    Ajoute un item dans ArrayList
Remove indice        Supprime un item
Clear                      Efface les items de ArrayList
Contains(item)       Teste si ArrayList contient l'item. Donne Vrai ou Faux
IndexOf(item)         Donne la position d'un item( -1 si non trouvé)
Sort                        Tri croissant
Reverse                  Inverse la liste
ToArray                  Convertit ArrayList en Array

Sub 1Dimension()
  Dim AL As Object
  Set AL = CreateObject("System.Collections.ArrayList")
  AL.Add "aaaa"
  AL.Add "bbbb"
  AL.Add "cccc"
  AL.Add "dddd"
  AL.Insert 2, "zzzz"
  AL.Insert 2, "yyyy"
  AL.Remove 2
  AL.Sort
  'MsgBox AL(3)
  'MsgBox AL.contains("bbbb")
  'MsgBox AL.indexof("cccc", 1)
  a = AL.ToArray ' Array a(1 to n)
  [a2].Resize(UBound(a)) = Application.Transpose(a)
End Sub

Alimentation d'un combobox une colonne avec liste triée

Form Liste triée ArrayList

Option Compare Text
Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  Set AL = CreateObject("System.Collections.ArrayList")
  a = f.Range("a2:a" & f.[A65000].End(xlUp).Row).Value
  For i = LBound(a) To UBound(a)
    If a(i, 1) <> "" Then AL.Add a(i, 1)
  Next i
  AL.Sort
  Me.ComboBox1.List = AL.ToArray
End Sub

Alimentation d'un combobox une colonne avec liste triée sans doublons

La colonne 4 de la BD contient des noms de villes

Private Sub UserForm_Initialize()
  Set f = Sheets("bd2")
  a = f.Range("A2:E" & f.[A65000].End(xlUp).Row).Value
  Set AL = CreateObject("System.Collections.Arraylist")
  For i = LBound(a) To UBound(a)
    If Not AL.contains(a(i, 4)) Then AL.Add a(i, 4)
  Next i
  AL.Sort
  Me.ComboBox1.List = AL.toarray
End Sub

ArrayList Multi-colonnes

Sub 2Dimensions()
  Dim AL As Object
  Set AL = CreateObject("System.Collections.ArrayList")
  AL.Add Array(11, "aaaa")
  AL.Add Array(22, "bbbb")
  AL.Add Array(33, "cccc")
  AL.Add Array(44, "dddd")
  AL.Insert 2, Array(99, "zzzz")
  AL.Insert 2, Array(88, "yyyy")
  AL.Remove 2
  'MsgBox AL(3)(1) ' col 2 du 4e item
  '---- Array 1D
  a = AL.ToArray       ' Array a(0 to n-1)
  'MsgBox a(3)(1)      ' col 2 du 4e item
  NbCol = UBound(a(0)) - LBound(a(0)) + 1
  For col = 1 To NbCol      ' transfert dans le tableur
    [g2].Offset(, col - 1).Resize(UBound(a) + 1) = Application.Index(a, , col)
  Next col
  '--- Array 2D
  b = Application.Transpose(AL.ToArray) ' Array a(1 to 2,1 to n)
  'MsgBox b(2, 3)
  [c2].Resize(UBound(b, 2), UBound(b)) = Application.Transpose(b)
End Sub

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

Classe AListe

Comparaison QuickSort et ArrayList.Sort

Pour 30.000 noms on obtient 0,25s pour QuickSort et 0,17s pour ArrayList.Sort mais il faut ajouter 0,89 s pour remplir ArrayList

Comparaison QuickSort/ ArrayList.Sort

Transfert d'une BD dans un ListBox sans les lignes vides

Le temps de transfert est inférieur avec un dictionnaire multi-colonnes.

TransfertBD sans lignes vides dans ListBox
TransfertBD sans lignes vides dans ListBox Trié Dictionary
TransfertBD sans lignes vides dans ListBox Trié ArrayList

Private Sub UserForm_Initialize()
  Set AL = CreateObject("System.Collections.ArrayList")
  a = [A2:D10000].Value
  For i = LBound(a) To UBound(a)
     If a(i, 1) <> "" Then AL.Add Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4))
  Next i
  Me.ListBox1.List = Application.Transpose(Application.Transpose(AL.toarray))
End Sub

Tri avec SortedList

Add clé,valeur
Clear
Contains(clé)
GetByIndex(indice)
GetKey (indice)
IndexOfKey
IndexOfValue
Remove clé

SortedList est conçu pour effectuer des tris multi-colonnes. Au fur et à mesure des ajouts d'items, la liste reste triée. Le tri est moins rapide que Quick-Sort dans un Array.

Tri multi-colonnes par nom avec SortedList

Tri SortedList
Tri Divers

SortedList n'accepte pas les doublons. S'il y a plusieurs noms identiques (SL.Add a(i, 1)& i, i)

Sub TriTableauNomSortedListIndexé()
  Set f = Sheets("bd1")
  a = f.Range("A2:E" & f.[A65000].End(xlUp).Row).Value
  ReDim b(LBound(a) To UBound(a), LBound(a, 2) To UBound(a, 2))
  Set SL = CreateObject("System.Collections.Sortedlist")
  For i = LBound(a) To UBound(a)
    SL.Add a(i, 1), i
  Next i
  For lig = LBound(a) To UBound(a)
    For col = LBound(a, 2) To UBound(a, 2)
      b(lig, col) = a(SL.GetByIndex(lig - 1), col)
    Next col
  Next lig
  [G2].Resize(UBound(b), UBound(b, 2)).Value2 = b
End Sub

Tri multi-colonnes par nom & prénom indexé

Sub TriTableauNomPrénomSortedList()
  Set f = Sheets("bd2")
  a = f.Range("A2:E" & f.[A65000].End(xlUp).Row).Value
  ReDim b(LBound(a) To UBound(a), LBound(a, 2) To UBound(a, 2))
  Set SL = CreateObject("System.Collections.Sortedlist")
  For i = LBound(a) To UBound(a)
    SL.Add a(i, 1) & a(i, 2), i
  Next i
  For lig = LBound(a) To UBound(a)
    For col = LBound(a, 2) To UBound(a, 2)
        b(lig, col) = a(SL.GetByIndex(lig - 1), col)
    Next col
  Next lig
  [G2].Resize(UBound(b), UBound(b, 2)).Value2 = b
End Sub

Tri multi-colonnes par ville indexé

SortedList n'accepte pas les doublons.

Sub TriTableauVilleSortedList()
  Set f = Sheets("bd2")
  a = f.Range("A2:E" & f.[A65000].End(xlUp).Row).Value
  ReDim b(LBound(a) To UBound(a), LBound(a, 2) To UBound(a, 2))
  Set SL = CreateObject("System.Collections.Sortedlist")
  For i = LBound(a) To UBound(a)
    SL.Add a(i, 4) & i, i
  Next i
  For lig = LBound(a) To UBound(a)
     For col = LBound(a, 2) To UBound(a, 2)
        b(lig, col) = a(SL.GetByIndex(lig - 1), col)
     Next col
   Next lig
   [G2].Resize(UBound(b), UBound(b, 2)).Value2 = b
End Sub

Listbox multi-colonnes Nom& prénom trié non indexé

Private Sub UserForm_Initialize()
  Set f = Sheets("bd2")
  a = f.Range("A2:E" & f.[A65000].End(xlUp).Row).Value
  ReDim b(LBound(a) To UBound(a), LBound(a, 2) To UBound(a, 2))
  Set SL = CreateObject("System.Collections.Sortedlist")
  For i = LBound(a) To UBound(a)
    SL.Add a(i, 1) & a(i, 2), Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4), a(i, 5))
  Next i
  Set AL = CreateObject("System.Collections.Arraylist")
  AL.AddRange SL.Values
  Me.ListBox1.Column = Application.Transpose(AL.toarray)
End Sub

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

Classe SListe
Classe SortedListe Collection David 84

Dans le fichier ci dessous, on trouvera un module de classe Dictionnaire (tableau 2D trié) qui remplace SortedList (temps tri 0,35s pour 10.000 lignes). En outre, il possède les propriétés de Dictionary.

Classe Dictionnaire

Différence entre 2 tableaux 2D: c()=a()-b()

DiffTableaux2D

Sub DiffTableau2Dimensions()
  Dim c()
  a = Evaluate("{1,2,3;4,5,6;7,8,9;10,11,12}")   ' 1 à 4 x 1 à 3
  b = Evaluate("{6,5,3;4,5,6;9,6,9;14,13,15}")   ' 1 à 4 x 1 à 3
  ReDim c(LBound(a, 1) To UBound(a, 1), LBound(a, 2) To UBound(a, 2))
  For lig = LBound(a, 1) To UBound(a, 1)
    For col = LBound(a, 2) To UBound(a, 2)
      c(lig, col) = b(lig, col) - a(lig, col)
    Next col
  Next lig
  [A2].Resize(UBound(c, 1), UBound(c, 2)) = c
End Sub

Split/Join

Split(chaine,séparateur)

Découpe une chaîne dans un tableau

Sub essai()
   chaine = "Dupont,Dupont@Hotmail.com)"
   a = Split(chaine, ",")
   Nom = a(0)
   Email = a(1)
End Sub

Transfert de variables x,y,w dans un tableau a()

x = 123
y = 456
w = 789
a = Split(x & "," & y & "," & w, ",")    ' tableau a(0 to 2)

Join(Tableau,séparateur)

Retourne dans une chaine la concaténation des éléments d'un tableau

Function TriCellule(c)
  temp = Split(c, " ")
  '---- tri
  For i = LBound(temp) To UBound(temp)
    For j = i To UBound(temp)
      If temp(j) < temp(i) Then
        sauv = temp(j)
        temp(j) = temp(i)
        temp(i) = sauv
      End If
   Next j
  Next i
  TriCellule = Join(temp, " ")
End Function

Fusion de 2 Array 1D

Sub FusionArray1D()
  a = Array(1, 2, 3, 4)
  b = Array(5, 6, 7)
  c = Split(Join(a, ",") & "," & Join(b, ","), ",")
  [a1].Resize(UBound(c) + 1) = Application.Transpose(c)
End Sub

Fusion de 2 colonnes A et E pour alimenter un combobox

Private Sub UserForm_Initialize()
  Me.ComboBox1.List = Split(Join(Application.Transpose(Range("A2:A" & [A65000].End(xlUp).Row)), ",") _
     & "," & Join(Application.Transpose(Range("E2:E" & [E65000].End(xlUp).Row)), ","), ",")
End Sub

Donne la liste des variables d’environnement :

For i=1 To 29
Cells(i, 1).Value = Split(Environ(i), "=")(0)
Cells(i, 2).Value = Split(Environ(i), "=")(1)
Next

Concatene les cellules d'un champ sans vides

on a une liste en A2,A3,A4,...

aa
bb
cc
dd

=concatchamp(A2:A5;",")

On otient aa,b,cc,dd

Function concatChamp(champ As Range, sep)
   concatChamp = Join(Application.Transpose(champ.Value), sep)
End Function

Si la liste a une longueur variable =concatchamp(DECALER(A2;;;NBVAL(A2:A100));",")

Pour obtenir aa,b,cc et dd

Function concatChamp(champ As Range, sep)
  temp = Join(Application.Transpose(champ.Value), sep)
  p = InStrRev(temp, ",")
  concatChamp = Left(temp, p - 1) & Replace(Mid(temp, p), ",", " et ")
End Function

Noms de champs indicés dynamiques

On ne peut pas créer de noms de variable indicés dynamiquement:
En revanche, on peut créer dynamiquement des noms indicés qui vont
contenir des valeurs.{2.3.4..}

Sub CreeNomsDynamiques()
  For i = 1 To 4
    ActiveWorkbook.Names.Add Name:= _
     "tableau" & i, RefersToR1C1:=Range(Cells(i, 1), Cells(i, 255).End(xlToLeft)).Value
    Next i
End Sub

Sub essai()
   i = 2
   x = "tableau" & i
   a = Evaluate([x]) ' Tableau2 est transféré dans le tableau a()
   MsgBox a(1)
End Sub

Extraction d'une ligne d'un tableau 2 dimensions a(,) dans un autre tableau b().

  a = [A1:H10]                           ' tableau à 2 dimensions
  b = Application.Index(a, 2)  ' 2e ligne tableau à 1 dimension
  MsgBox b(1)

  a = [A1:B10] ' tableau à 2 dimensions
  b = Application.Index(Application.Transpose(a), 2) ' 2e colonne tableau à 1 dimension
  MsgBox b(3)

Transfert d'une Colonne d'un tableau 2 dimensions dans un tableau 1 dimension

Sub TransfertColonneTableau2DDansTableau1D()
  Dim a(1 To 3, 1 To 3)
  a(1, 1) = 11
  a(2, 1) = 12
  a(3, 1) = 13

  a(1, 2) = 21
  a(2, 2) = 22
  a(3, 2) = 23

  a(1, 3) = 31
  a(2, 3) = 32
  a(3, 3) = 33
  '-- 2eme colonne du tableau a(,) dans tableau c(,) à 2 dimensions (3 x1 )
  c = Application.Index(a, , 2)
  ' -- transfert dans le tableur
  [A2].Resize(UBound(c)) = c
  '-- 2eme colonne du tableau a(,) dans tableau d() à 1 dimension
  d = Application.Transpose(Application.Index(a, , 2))
  ' -- transfert dans le tableur
  [C2].Resize(UBound(c)) = Application.Transpose(d)
End Sub

Recherche dans la première colonne d'un tableau 2 dimensions

a = [A1:B4]
x = "cc"
p = Application.Match(x, Application.Index(a, , 1), 0)
MsgBox p
MsgBox a(p, 2)

Transposition de tableaux

TransposeTableau

Sub Essai_Transposer1Colonne()
  '1 colonne
  table1 = Range("A1:A10").Value          ' 2 dimensions 10x1
  table2 = Application.Transpose(table1) ' 1 dimension 10
  MsgBox table2(3)
  [F10].Resize(, UBound(table2, 1)) = table2
End Sub

Sub Essai_Transposer2Colonnes()
  '2 colonnes
  table1 = Range("C1:D10").Value           ' 2 dimensions 10x2
  table2 = Application.Transpose(table1)  ' 2 dimensions 2x10
  MsgBox table2(2, 3)
  [F1].Resize(UBound(table2, 1), UBound(table2, 2)) = table2
End Sub

Sub essai()
  table1 = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10)
  table2 = Application.Transpose(table1)    ' 1 dimension 10
  [F20].Resize(UBound(table2, 1)) = table2 ' 2 dimensions 10x1
End Sub

Sub essai2()
  Dim table1(1 To 10)
  For i = 1 To 10: table1(i) = i: Next i      ' 1 dimension 10
  table2 = Application.Transpose(table1) ' 2 dimensions 10 x 1
  [F20].Resize(UBound(table2, 1)) = table2
End Sub

On veut transférer les colonnes 1,3,4 d'un tableau a(7,5) dans le tableur

Transfert

Sub essai()
  a = [A1:E7]   ' a() tableau 5 colonnes
  '---                 on veut transferer les colonnes 1,3,4
  i = 0
  For Each col In Array(1, 3, 4)
    [G1:G7].Offset(, i) = Application.Index(a, , col)
    i = i + 1
  Next col
End Sub

Somme de lignes/colonnes d'un tableau 3D

SommeTableau

Sub essai2()
  Dim Tableau(1 To 10, 1 To 9, 1 To 12) ' 10 lignes/9 colonnes
  Dim y As Integer, x As Integer, z As Integer
  For y = LBound(Tableau, 1) To UBound(Tableau, 1)
     For x = LBound(Tableau, 2) To UBound(Tableau, 2)
       For z = LBound(Tableau, 3) To UBound(Tableau, 3)
          Tableau(y, x, z) = Sheets(z).Cells(y, x)
       Next z
    Next x
  Next y
  MsgBox SommeTableau(Tableau, Empty, 1, 4) ' Somme Colonne1/ Feuil4
  MsgBox SommeTableau(Tableau, 2, Empty, 4) ' Somme Ligne 2/Feuil4
  MsgBox SommeTableau(Tableau, 1, 1, Empty) ' Somme Ligne1/Colonne1/Toutes les feuilles
  MsgBox SommeTableau(Tableau, 3, 2, 1)        ' Ligne3/Colonne2/Feuil1
End Sub

Function SommeTableau(T(), Lig, Col, F)
  If IsEmpty(Col) Then
     For x = LBound(T, 2) To UBound(T, 2)
        temp = temp + T(Lig, x, F)
     Next x
   Else
     If IsEmpty(Lig) Then
       For y = LBound(T, 1) To UBound(T, 1)
         temp = temp + T(y, Col, F)
       Next y
     Else
        If IsEmpty(F) Then
           For z = LBound(T, 3) To UBound(T, 3)
             temp = temp + T(Lig, Col, z)
           Next z
        Else
           temp = T(Lig, Col, F)
        End If
     End If
   End If
   SommeTableau = temp
End Function

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

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

Fonction Somme3D 2 critères

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

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

Autre version

Somme3D 2 critères

-Sélectionner A1:H12
=s3DTriée(1;5;"A2:A10";"B1:E1";"B2:E10")
-Valider avec maj+ctrl+entrée

Recherche dichotomique dans un Array trié

Recherche Dichotomique

Sub RechDichotomique()
  t = Timer()
  a = [A1:B60000]
  'Call tri(a, 1, UBound(a), 2, 1)
  N = 60000
  For j = 1 To 60000 Step 2 ' 30000 recherches
    cherche = "Nom" & Format(j, "00000")
    Inf = 1: Sup = N
    Do
        If Inf > Sup Then Position = -1: Exit Do
        Milieu = Int((Inf + Sup) / 2)
        If cherche < a(Milieu, 1) Then
          Sup = Milieu - 1
        Else
            If cherche > a(Milieu, 1) Then
               Inf = Milieu + 1
            Else
               Position = Milieu: Exit Do
            End If
        End If
     Loop
     If Position <> -1 Then
        y = a(Position, 2)
     Else
        Stop
     End If
   Next j
   MsgBox Timer() - t
End Sub

Exemples divers

Total Factures
Transformation tableau
Synthèse tableau
Items pour un code dans un Array 2D
Items pour un code dans un Array 2D Sans Doublons pour les items
Items pour un code dans un Array 2D Sans Doublons pour les items MAC

 


 

 


 

 

 

 

 

 

 

 

Exemples

Arrays Synthèse
FonctionSansDoublonsTriée
FonctionTri
SansDoublonsTriéeMultiZones