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.
|
|
Tableau à 1 dimension a(1 To 5)
|
Tableau à 2 dimensions b(3,2)
|
Déclaration des tableaux (Arrays)
Dim tableau(taille)
Dim tableau(indice1bas TO indice1Haut,indice2Bas TO indice2Haut,...)
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
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 TableauEmboités()
Dim Tbl(1 To 3)
For n = 1 To 3
Tbl(n) = Sheets(n).[A1:C5]
Next n
MsgBox Tbl(3)(2, 2)
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
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.
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(),...
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)
Connaître le nombre de dimensions d'un Array
Sub essaiDim()
a = Array(1, 2, 3)
MsgBox ArrayDim(a)
a = [A2:B10]
MsgBox ArrayDim(a)
End Sub
Function ArrayDim(Tbl)
On Error Resume Next
For d = 1 To 3
tmp = UBound(Tbl, d)
If Err Then ArrayDim = d - 1: Exit Function
Next d
End Function
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
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
Transfert d'une colonne ou d'une ligne d'un tableau 2D (Array) dans un Array
Le temps d'extraction d'une colonne d'un Array dans un autre Array avec Application.Index(Array,,colonne) est sensiblement plus lent que la méthode classique.
SubTransfertColonneArray2DArray()
a = [A1:C50000]
b = Application.Index(a, , 2) '
Array 2D (1 to 50000,1 to 1)
MsgBox b(1, 1)
End Sub
Sub TransfertClassiqueColonneArray2DArray1d()
a = [A1:C50000]
b = ExtraitCol(a, 2)
' Array 1D (1 to 50000)
MsgBox b(1)
End Sub
Function ExtraitCol(a, col)
ReDim b(LBound(a) To UBound(a))
For i = LBound(a) To UBound(a): b(i) = a(i, col): Next i
ExtraitCol = b
End Function
Filtre de lignes par une clé dans un Array 2D
Sur cet exemple la sélection de 10.000 lignes sur 20.000 lignes prend 0,03 sec
Filtre
Array multi-colonnes Clé
Filtre Array multi-colonnes
entre 2 dates
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 FiltreArrayCléColRécup(Tbl, clé, colClé, colRécup) retourne dans un tableau les lignes vérifiant le critère spécifié. Sur l'exemple, Tbl = FiltreArrayLignes(Tablo, 3, "Paris",Array(1,3,4)) récupère dans un tableau Tbl() les lignes de Paris et les colonnes 1,3,4.
Fonction Filtre Array multi-colonnes Clé
Sub EssaifiltreArrayFonctionCol()
Set f = Sheets("bd")
Tbl1 = f.Range("A2:D" & f.[A65000].End(xlUp).Row).Value
Tbl = FiltreArrayCléColRécup(Tbl1, "Paris",
3, Array(1, 3, 4))
If Not IsEmpty(Tbl) Then f.[G2].Resize(UBound(Tbl), UBound(Tbl,
2) - LBound(Tbl, 2) + 1) = Tbl
End Sub
Function FiltreArrayCléColRécup(Tbl, clé, colClé,
colRécup)
n = 0
For i = 1 To UBound(Tbl)
If Tbl(i, colClé) = clé Then n =
n + 1
Next i
Dim Tbl2(): ReDim Tbl2(1 To n, LBound(colRécup) To
UBound(colRécup))
n = 0
For i = 1 To UBound(Tbl)
If Tbl(i, colClé) = clé Then
n = n + 1
For k = LBound(colRécup)
To UBound(colRécup):Tbl2(n, k) = Tbl(i, colRécup(k)):Next
k
End If
Next i
If n > 0 Then FiltreArrayCléColRécup = Tbl2
End Function
Clé multiple
Pour une BD de 100.000 lignes et 200 valeurs de clé , on obtient un temps de 0,15 sec (0,30 pour filtre avancé).
Filtre Array multi-colonnes Clé multiple
Sub EssaifiltreArrayFonctionCol()
Set f = Sheets("bd")
Tbl1 = f.Range("A2:C" & f.[A1000000].End(xlUp).Row).Value
Dim TblCaté(1 To 200): For i = 1 To 200: TblCaté(i)
= i: Next i
Tbl = FiltreArrayCléColRécup(Tbl1, TblCaté,
1, Array(1, 2, 3))
If Not IsEmpty(Tbl) Then Sheets("Résultat").[A2].Resize(UBound(Tbl),
UBound(Tbl, 2) - LBound(Tbl, 2) + 1) = Tbl
End Sub
Function FiltreArrayCléColRécup(Tbl, clé, colClé,
colRécup)
n = 0
Set d = CreateObject("scripting.dictionary")
For Each c In clé: d(c) = "": Next c
For i = 1 To UBound(Tbl)
If d.exists(Tbl(i, colClé)) Then n = n
+ 1
Next i
Dim Tbl2(): ReDim Tbl2(1 To n, LBound(colRécup) To
UBound(colRécup))
n = 0
For i = 1 To UBound(Tbl)
If d.exists(Tbl(i, colClé)) Then
n = n + 1
For k = LBound(colRécup) To
UBound(colRécup): Tbl2(n, k) = Tbl(i, colRécup(k)): Next
k
End If
Next i
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)
Suppression d'une ligne d'un Array 2D
Sub SupLigneArray()
Set f = Sheets("bd")
Tbl = f.Range("A2:D" & f.[A65000].End(xlUp).Row).Value
Tbl = DeleteLigne(Tbl, 3) ' suppression
de la ligne 3
f.[K2].Resize(UBound(Tbl), UBound(Tbl, 2)) = Tbl
End Sub
Function DeleteLigne(Tbl, ligne)
Dim Tbl2: ReDim Tbl2(1 To UBound(Tbl) - 1, 1 To UBound(Tbl,
2))
For i = 1 To UBound(Tbl)
If i <> ligne Then j = j + 1: For k = 1
To UBound(Tbl, 2): Tbl2(j, k) = Tbl(i, k): Next k
Next i
DeleteLigne = Tbl2
End Function
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
Fonction
filtre colonnes 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
Autres méthodes
-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
Conversion champ Union en Array
Sub essai()
Set Rng = Range("A2:A10,C2:C10,E2:E10") '
Champ Union
Tbl = Tableau(Rng)
[I2].Resize(UBound(Tbl), UBound(Tbl, 2)) = Tbl
End Sub
Function Tableau(Rng)
NbLig = Rng.Rows.Count: NbCol = Rng.Areas.Count
Dim Tbl(): ReDim Tbl(1 To NbLig, 1 To NbCol)
For i = 1 To NbCol
For j = 1 To NbLig: Tbl(j, i) = Rng.Areas(i)(j):
Next j
Next i
Tableau = Tbl
End Function
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
Voici une fonction qui convertit en un tableau à 1 dimension . Elle est plus rapide que Appication.Transpose.
Sub essaiTransposeJB()
Tbl = [A2:A73000].Value
Tbl = Transpose1D(Tbl)
Tbl = Filter(Tbl, "xxxx") ' Tbl doit être
à 1 dimension
[D2].Resize(UBound(Tbl) - LBound(Tbl) + 1) = Application.Transpose(Tbl)
' vérif
End Sub
Function Transpose1D(Tbl) ' convertit en 1 table à
1 dimension
ReDim Tbl2(1 To UBound(Tbl))
For i = 1 To UBound(Tbl)
Tbl2(i) = Tbl(i, 1)
Next i
Transpose1D = Tbl2
End Function
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.
Sur Mac, Remplace la fonction Filter()
Fonction
Filtre() sur Mac
Fonction Filtre()
sur Mac Patrick Toulon
Option Compare Text
Sub essaiFiltre()
Set f = Sheets("feuil1")
Tbl = Application.Transpose(f.Range("A2:A13" &
f.[A65000].End(xlUp).Row).Value)
clé = "Mar"
Tbl = Filtre(Tbl, clé)
If Not IsEmpty(Tbl) Then f.[c2].Resize(UBound(Tbl)) = Application.Transpose(Tbl)
End Sub
Function Filtre(Tbl, clé)
n = 0: Dim b()
For i = LBound(Tbl) To UBound(Tbl)
If Tbl(i) Like "*" & clé
& "*" Then
n = n + 1
ReDim Preserve b(1 To n): b(n)
= Tbl(i)
End If
Next i
If n > 0 Then Filtre = b
End Function
Compter le nombre de fois où apparaît un mot dans la colonne d'un Array()
n= UBound(Filter(Application.Transpose(Application.Index(a, , 5)), "Annulé")) + 1
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
Filtre
Array Multi-colonnes clé multiple
Recherche
BD avec choix de la colonne de recherche
Recherche
BD intuitive avec choix de la colonne de recherche
Filtre Array
Multi-colonnes clé multi-colonnes
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
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
Tri de colonnes discontinues
On veut trier A,B,D,E mais pas C
Sub TriColonnesDiscontinues()
Set Rng = Range("A2:E10")
n = Rng.Rows.Count
Tbl = Application.Index(Rng, Evaluate("Row(1:" &
n & ")"), Array(1, 2, 4, 5))
Tri Tbl, 1, LBound(Tbl), UBound(Tbl)
b = Application.Index(Tbl, Evaluate("Row(1:" &
n & ")"), Array(1, 2))
[a2].Resize(UBound(b), UBound(b, 2)) = b
b = Application.Index(Tbl, Evaluate("Row(1:" &
n & ")"), Array(3, 4))
[d2].Resize(UBound(b), UBound(b, 2)) = b
End Sub
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)
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é classique
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
Prendre une partie d'un Array
Sub PrendPartieArray()
a = Range("A1:C20")
Début = 11
Taille = 5
fin = Début + Taille - 1
b = Application.Index(a, Evaluate("Row(" & Début
& ":" & fin & ")"), Application.Transpose(Evaluate("Row(1:"
& UBound(a, 2) & ")")))
[d2].Resize(UBound(b), UBound(b, 2)) = b
End Sub
Prendre
partie d'un Array Classique
Fonction
Prendre partie d'un Array Classique
Sub PrendPartieArrayClassique()
TblE = Range("A1:C22")
Début = 11
Taille = 5
fin = Début + Taille - 1: If fin > UBound(TblE)
Then fin = UBound(TblE)
Dim TblS(): ReDim TblS(1 To Taille, 1 To UBound(TblE))
n = 0
For i = Début To fin
n = n + 1: For k = 1 To UBound(TblE, 2): TblS(n,
k) = TblE(i, k): Next k
Next i
[e2].Offset(, décal).Resize(UBound(TblS), UBound(TblS,
2)) = TblS
End Sub
Découper un Array en blocs
Découpe
Array en Blocs
Découpe
Array en Blocs Classique
Fonction
Prend partie Array Classique
Sub DécoupeArrayBlocs()
a = Range("A1:C22") ' Array a()
début = 1
TailleBloc = 5
décal = 0
Do While début <= UBound(a)
fin = début + TailleBloc - 1: If fin >
UBound(a) Then fin = UBound(a)
b = Application.Index(a, Evaluate("Row("
& début & ":" & fin & ")"),
Application.Transpose(Evaluate("Row(1:" & UBound(a,
2) & ")")))
[e2].Offset(, décal).Resize(UBound(b),
UBound(b, 2)) = b
décal = décal + UBound(a, 2) + 1
début = fin + 1
Loop
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.
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
Fonction
Extraction Array Clé Classique
Extraction Array
Onglets
-Nous créons un dictionnaire d des codes. Pour chaque code, nous stockons les nos de lignes du tableau(Array)
Sub ExtraitTousCodes()
Set f = Sheets("BD")
Application.DisplayAlerts = False
Application.ScreenUpdating = False
bd = f.Range("A2:C" & f.[A65000].End(xlUp).Row)
Set d = CreateObject("scripting.dictionary")
For i = 1 To UBound(bd): d(bd(i, 2)) = d(bd(i, 2)) & i
& ",": Next ' dictionnaire
ligne = 1
f.Cells(ligne, "f").Resize(1000, 3).ClearContents
For Each k In d.keys
Cells(ligne, "e") = k
Cells(ligne, "f") = f.[A1]:
Cells(ligne, "h") = f.[c1]
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
End Sub
Pour filtrer un seul code
Sub ExtraitUnCode()
Set f = Sheets("BD")
Application.DisplayAlerts = False
Application.ScreenUpdating = False
bd = f.Range("A2:C" & f.[A65000].End(xlUp).Row)
code = "603102511"
Set d = CreateObject("scripting.dictionary")
For i = 1 To UBound(bd)
If bd(i, 2) = code Then d(i) = "" '
on stocke les nos de ligne
Next i
a = Application.Index(bd, Application.Transpose(d.keys),
Array(1, 3)) 'extract Array
f.[E2] = code
f.[g2].Resize(UBound(a) - 1, UBound(a, 2)) = a
End Sub
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é Classique
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
Suppression des doublons
d'un Array (toutes colonnes)
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.
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"))
Calcul du minimum d'une colonne d'un Array
Sub MiniArray()
n = 64000
Dim a(): ReDim a(1 To n, 1 To 2)
For i = LBound(a) To UBound(a)
a(i, 2) = 100000 - i
Next i
t = Timer()
Min = Application.Min(Application.Index(a, , 2))
MsgBox Timer() - t
MsgBox Min
End Sub
Application.index(tbl,,colonne) ne fonctionne
plus pour un Array de plus de 65536 lignes.
Avec une fonction, le calcul est 10 fois plus rapide.
Sub AppelFonctionMini()
n = 64000
Dim a(): ReDim a(1 To n, 1 To 2)
For i = LBound(a) To UBound(a)
a(i, 2) = 100000 - i
Next i
t = Timer()
Min = Mini(a, 2)
MsgBox Timer() - t
MsgBox Min
End Sub
Function Mini(a, col) ' minimum d'une colonne d'Array
Mini = a(1, col)
For i = LBound(a) To UBound(a)
If a(i, 2) < Mini Then Mini = a(i, col)
Next i
End Function
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).
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
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
Ajout d'une colonne à un Array 2D
Sur cet exemple, nous filtrons les lignes d'un Array BD(,) pour les ajouter à un Array(,) à l'aide la procédure AjoutEnreg.
Private Sub ComboBox1_click()
Dim Tbl(): ReDim Tbl(1 To NCol, 0 To 0)
Dim Enreg(): ReDim Enreg(1 To NCol)
For i = 1 To UBound(BD)
If BD(i, 1) = Me.ComboBox1 Then AjoutEnreg
Tbl, Array(BD(i, 1), BD(i, 2), BD(i, 3), BD(i, 4))
Next i
Me.ListBox1.Column = Tbl
End Sub
Sub AjoutEnreg(Tbl, Enreg)
NCol = UBound(Tbl): n = UBound(Tbl, 2) + 1
ReDim Preserve Tbl(1 To NCol, 1 To n)
For k = LBound(Enreg) To UBound(Enreg)
Tbl(k + 1, n) = Enreg(k)
Next k
End Sub
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).
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
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 .
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.
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
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 un produit et une opération.
-L'utilisateur peut choisir les colonnes à afficher ainsi que l'ordre
d'affichage.
-On peut également l'ordre d'affichage.
-sélectionner A6:H22
=FiltreBD(BD;1;H2;{1;2;3;4;5;6;7;8};2;F2)
-valider avec maj+ctrl+entrée
FiltreBD
2 criteres
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()
Nlignes = Application.Caller.Rows.Count
If IsArray(ColResult) Then
ReDim b(LBound(a) To Application.Caller.Rows.Count,
1 To UBound(ColResult) - LBound(ColResult) + 1)
Else
ReDim b(LBound(a) To Nlignes, 1 To 1)
End If
If IsMissing(colcrit2) Then colcrit2 = colCrit1: critere2
= critere1
For i = LBound(a, 1) To UBound(a, 1)
If a(i, colCrit1) <> "" Then
If (UCase(a(i, colCrit1)) =
UCase(critere1) Or critere1 = "") And _
(UCase(a(i,
colcrit2)) = UCase(critere2) Or critere2 = "") Then
If IsArray(ColResult) Then
For c = LBound(ColResult)
To UBound(ColResult)
col
= ColResult(c, 1)
b(k,
c) = a(i, col)
Next c
Else
b(k, ColResult)
= a(i, ColResult)
End If
k = k + 1: If k > Nlignes Then FiltreBD
= "pas assez de lignes": Exit Function
End If
End If
Next i
If Not IsMissing(coltri) Then Call TriCol(b, LBound(b), k - 1, coltri)
FiltreBD = b
End Function
Sous total tableau trié
Sub SousTotal()
[A1].Sort Key1:=[A1], Order1:=xlAscending, Header:=xlYes
TblE = Range("A2:B" & [a65000].End(xlUp).Row)
' Table entrée
Dim TblS(): ReDim TblS(1 To UBound(TblE), 1 To 2) '
Table Sortie
i = 1: n = 0
Do While i <= UBound(TblE)
n = n + 1: TblS(n, 1) = TblE(i, 1)
Do While TblE(i, 1) = TblS(n, 1)
TblS(n, 2) = TblS(n, 2)
+ TblE(i, 2) ' Totalisation colonne 2
i = i + 1: If i > UBound(TblE)
Then Exit Do
Loop
Loop
[E2].Resize(n, UBound(TblS, 2)) = TblS
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 TblE() n'est pas trié:
Sous
Total 2 col Num
Sous Total 2
col Num MAC
Sous Total
2 col Num Total Colonnes
Sous Total 2 col Texte
La table TblS() est indexée par le dictionnaire d pour permettre un accès plus rapide à chaque ligne de la table TblS().
Sub SousTotalNonTrié()
Set d = CreateObject("Scripting.Dictionary")
TblE = Range("A2:C" & [a65000].End(xlUp).Row)
' Table entrée
Dim TblS(): ReDim TblS(1 To UBound(TblE), 1 To UBound(TblE,
2)) ' Table sortie
For i = LBound(TblE) To UBound(TblE)
If d.exists(TblE(i, 1)) Then
lig = d(TblE(i, 1))
' Récupération index TblS()
Else
d(TblE(i, 1)) = d.Count + 1: lig = d.Count:
TblS(lig, 1) = TblE(i, 1)
End If
For c = 2 To UBound(TblE, 2): TblS(lig, c) = TblS(lig,
c) + TblE(i, c): Next c ' Totalisation numérique
Next i
[E2].Resize(d.Count, UBound(TblS, 2)) = TblS
End Sub
ou
Sub SousTotalNonTrié2()
Set d = CreateObject("Scripting.Dictionary")
TblE = Range("A2:C" & [a65000].End(xlUp).Row)
' Table entrée
Dim TblS(): ReDim TblS(1 To UBound(TblE), 1 To UBound(TblE,
2)) ' Table sortie
maxi = 0
For i = LBound(TblE) To UBound(TblE)
If d.exists(TblE(i, 1)) Then
p = d(TblE(i, 1))
' Récupération index TblS()
TblS(p, 2) = TblS(p, 2) + TblE(i,
2)
TblS(p, 3) = TblS(p, 3) + TblE(i,
3)
Else
maxi = maxi + 1
d(TblE(i, 1)) = maxi
TblS(maxi, 1) = TblE(i, 1)
TblS(maxi, 2) = TblE(i, 2)
TblS(maxi, 3) = TblE(i, 3)
End If
Next i
[E2].Resize(d.Count, UBound(TblS, 2)) = TblS
End Sub
b/Si la table TblE() est triée (fonctionne sur PC & MAC)
Cette méthode est aussi rapide que l'utilisation
du dictionnaire. Elle peut être utilisée pour le MAC qui
ne dispose pas du dictionnaire.
Pour 20.000 lignes (0,07 sec -0,03 sec si déjà trié/
Dictionary: 0,05 sec/ Collection: 0,11
sec)
Sub SousTotalTablo2col()
[A1].CurrentRegion.Sort , key1:=[A2], Header:=xlYes
TblE = Range("A2:D" & [a65500].End(xlUp).Row)
'
Table entrée
Dim TblS(): ReDim TblS(1 To UBound(TblE), 1 To UBound(TblE,
2)) ' Table sortie
i = 1: n = 0
Do While i <= UBound(TblE)
n = n + 1
clé = TblE(i, 1)
For c = 1 To 2: TblS(n, c) = TblE(i, c): Next
c
Do While TblE(i, 1) = clé
For c = 3 To 4: TblS(n, c) =
TblS(n, c) + TblE(i, c): Next c
i = i + 1: If i > UBound(TblE)
Then Exit Do
Loop
Loop
[J2].Resize(n, UBound(TblS, 2)) = TblS
End Sub
Avec l'objet Collection (fonctionne sur PC & MAC)
Sub SousTotalCollection()
Dim Collec1 As New Collection
TblE = Range("A2:D" & [a65000].End(xlUp).Row) '
Table entrée
Dim TblS(): ReDim TblS(1 To UBound(TblE), 1 To UBound(TblE,
2)) " Table sortie
For i = LBound(TblE) To UBound(TblE)
clé = TblE(i, 1)
On Error Resume Next
Collec1.Add Item:=Collec1.Count + 1, Key:=clé
If Err > 0 Then
lig = Collec1(clé)
Else
lig = Collec1.Count: TblS(lig, 1)
= TblE(i, 1): TblS(lig, 2) = TblE(i, 2)
End If
For c = 3 To UBound(TblE, 2): TblS(lig, c) = TblS(lig,
c) + TblE(i, c): Next c ' Totalisation colonnes 3
& 4
Next i
[J2].Resize(n, UBound(TblS, 2)) = TblS
End Sub
Critère multi-colonnes
La clé de regroupement est la concaténation du nom et du prénom.
clé = TblE(i, 1) & "|" & TblE(i, 2)
Sous Total 2 col critère multi-colonnes
Sub SousTotalNonTrié()
Set d = CreateObject("Scripting.Dictionary")
TblE = Range("A2:D" & [a65000].End(xlUp).Row)
' Table entrée
Dim TblS(): ReDim TblS(1 To UBound(TblE), 1 To UBound(TblE,
2)) ' Table sortie
For i = LBound(TblE) To UBound(TblE)
clé = TblE(i, 1) & "|"
& TblE(i, 2) ' Clé multi-colonnes
If d.exists(clé) Then
lig = d(clé)
' Récupération index TblS()
Else
d(clé) = d.Count + 1: lig = d.Count:
TblS(lig, 1) = TblE(i, 1): TblS(lig, 2) = TblE(i, 2) '
Nouvelle clé
End If
For c = 3 To UBound(TblE, 2): TblS(lig, c) = TblS(lig,
c) + TblE(i, c): Next c ' Totalisation colonnes numériques
Next i
[F2].Resize(d.Count, UBound(TblS, 2)) = TblS
End Sub
Sous-total avec plusieurs colonnes
Synthèse tableau plusieurs colonnes
Sub SousTotalPLusieursColonnes()
Set f = Sheets("données")
Set Result = f.Range("J1")
' Adresse résultat
TblBD = f.Range("A1:E" & f.[A65000].End(xlUp).Row)
' Array pour rapidité
Ncol = UBound(TblBD, 2)
Set d = CreateObject("Scripting.Dictionary")
Dim TblS(): ReDim TblS(1 To UBound(TblBD), 1 To Ncol)
Dim TblTotCol(): ReDim TblTotCol(1 To Ncol)
Dim TblTotLig(): ReDim TblTotLig(1 To 1000)
For i = 2 To UBound(TblBD)
clé = TblBD(i, 1)
If Not d.exists(clé) Then d(clé)
= d.Count + 1: lig = d(clé) Else lig = d(clé) ' gestion
index
For k = 2 To Ncol
TblS(lig, k) = TblS(lig,
k) + TblBD(i, k)
TblTotCol(k) = TblTotCol(k)
+ TblBD(i, k) ' total colonne
TblTotLig(lig) = TblTotLig(lig)
+ TblBD(i, k) ' total ligne
Next k
Next i
Result.Offset(1).Resize(d.Count + 1, Ncol) = TblS
Result.Offset(1).Resize(d.Count, 1) = Application.Transpose(d.keys)
' titres lignes
Result.Offset(1, Ncol).Resize(d.Count) = Application.Transpose(TblTotLig)
' totaux lignes
Result.Resize(1, Ncol) = Application.Index(TblBD, 1)
' titres colonnes
Result.Offset(d.Count + 1).Resize(, Ncol) = TblTotCol
' totaux colonnes
Result.Offset(1).Resize(d.Count, Ncol + 2).Sort key1:=Result.Offset(1),
Order1:=xlAscending, Header:=xlNo
End Sub
Tableau avec plusieurs colonnes espacées.
Synthèse tableau plusieurs colonnes espacées
Autre exemple
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 SousTotalNonTrié()
Set d = CreateObject("Scripting.Dictionary")
T1 = Range("A2:D" & [a65000].End(xlUp).Row)
Dim T2(): ReDim T2(1 To UBound(T1), 1 To UBound(T1, 2))
For i = LBound(T1) To UBound(T1)
If d.exists(T1(i, 2)) Then p = d(T1(i, 2)) Else
d(T1(i, 2)) = d.Count + 1: p = d.Count
T2(p, 1) = T2(p, 1) + T1(i, 1) ' totalisation
colonne Qte
For k = 2 To 4: T2(p, k) = T1(i, k): Next k '
copie des autres colonnes
Next i
[H2].Resize(d.Count, UBound(T2, 2)) = T2
[A1:D1].Copy [H1]
End Sub
Si la table T1() 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
Regroupement dans un Array() avec critère multi-colonnes (élimination des doublons)
Sub Regroupement()
Set d = CreateObject("Scripting.Dictionary")
TblE = Range("A2:L13")
' Array entrée
Dim TblS(): ReDim TblS(1 To UBound(TblE), 1 To 4)
' Array sortie
For i = LBound(TblE) To UBound(TblE)
clé = TblE(i, 3) & "|" &
TblE(i, 4) ' clé de regroupement
If Not d.exists(clé) Then
d(clé) ="": lig =
d.Count: TblS(lig, 1) = TblE(i, 3): TblS(lig, 2) = TblE(i, 4) ' Nouvelle
clé
For c = 3 To UBound(TblS, 2): TblS(lig,
c) = TblE(i, c + 4): Next c ' recopie des autres colonnes
End If
Next i
[C17].Resize(d.Count, UBound(TblS, 2)) = TblS
End Sub
Consolidation de plusieurs tableaux
Dim d1, d2
Sub consolide2()
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
a = [E3:G3].Resize([E2].CurrentRegion.Rows.Count - 2)
totalise a
a = [I3:K3].Resize([I2].CurrentRegion.Rows.Count - 2)
totalise a
[a3].Resize(d1.Count) = Application.Transpose(d1.keys)
[b3].Resize(d1.Count) = Application.Transpose(d1.items)
[c3].Resize(d2.Count) = Application.Transpose(d2.items)
End Sub
Sub totalise(a)
For i = LBound(a) To UBound(a)
d1(a(i, 1)) = d1(a(i, 1)) + a(i, 2)
d2(a(i, 1)) = d2(a(i, 1)) + a(i, 3)
Next i
End Sub
Consolidation de tableaux 2D
Option Compare Text
Dim d1, d2, TblE(), Tstat(), TblTotLig(), TblTotCol()
Sub ConsolideTab2D()
Set d1 = CreateObject("Scripting.Dictionary") '
lignes
d1.CompareMode = vbTextCompare
Set d2 = CreateObject("Scripting.Dictionary") '
colonnes
d2.CompareMode = vbTextCompare
ReDim Tstat(1 To 100, 1 To 100): ReDim TblTotLig(1 To 100):
ReDim TblTotCol(1 To 100)
TblE = Sheets("BD1").Range("C1").CurrentRegion.Value
Consolide
TblE = Sheets("BD2").Range("C1").CurrentRegion.Value
Consolide
Set Result = Range("a1")
Result.Offset(1, 1).Resize(d1.Count, d2.Count) = Tstat
Result.Offset(1).Resize(d1.Count) = Application.Transpose(d1.keys)
' titres lignes
Result.Offset(, 1).Resize(, d2.Count) = d2.keys
' titres colonnes
Result.Offset(1).Offset(d1.Count, 1).Resize(, d2.Count) =
TblTotCol ' totaux colonnes
Result.Offset(1, 1).Offset(, d2.Count).Resize(d1.Count) =
Application.Transpose(TblTotLig) ' totaux lignes
Result.Offset(d1.Count + 1) = "Total "
Result.Offset(, d2.Count + 1) = "Total"
'---tri lignes et colonnes
Set Rng = Result.CurrentRegion
Rng.Offset(1).Resize(Rng.Rows.Count - 1, Rng.Columns.Count).Sort
key1:=Rng.Cells(2, 1), _
Order1:=xlAscending, Header:=xlNo, MatchCase:=False, Orientation:=xlSortColumns
Rng.Offset(, 1).Resize(Rng.Rows.Count, Rng.Columns.Count -
1).Sort key1:=Rng.Cells(1, 2), _
Order1:=xlAscending, Header:=xlNo, MatchCase:=False,
Orientation:=xlSortRows
End Sub
Sub Consolide()
For i = 2 To UBound(TblE)
clé = TblE(i, 1) & " " & TblE(i,
2)
If d1.exists(clé) Then lig = d1(clé) Else d1(clé)
= d1.Count + 1: lig = d1.Count ' gestion index lignes
For c = 3 To UBound(TblE, 2)
If d2.exists(TblE(1, c)) Then col = d2(TblE(1,
c)) Else d2(TblE(1, c)) = d2.Count + 1: col = d2.Count ' index
Tstat(lig, col) = Tstat(lig, col)
+ TblE(i, c) ' totalisation
TblTotLig(lig) = TblTotLig(lig) +
TblE(i, c)
TblTotCol(col) = TblTotCol(col) +
TblE(i, c)
Next c
Next i
End Sub
Fusion de 2 tableaux
Fusion_2014_2015
Consolidation_tableaux
2D
Sub fusion()
Set d1 = CreateObject("Scripting.Dictionary")
Set f1 = Sheets("ca2014")
a = f1.Range("A2:B" & f1.[a65000].End(xlUp).Row)
Set f2 = Sheets("ca2015")
b = f2.Range("A2:B" & f2.[a65000].End(xlUp).Row)
n = UBound(a) + UBound(b)
Dim c: ReDim c(1 To n, 1 To 3)
m = 0
For i = LBound(a) To UBound(a)
If Not d1.exists(a(i, 1)) Then m = m + 1: d1(a(i,
1)) = m: p = m Else p = d1(a(i, 1))
c(p, 1) = a(i, 1): c(p, 2) = a(i, 2)
Next i
For i = LBound(b) To UBound(b)
If Not d1.exists(b(i, 1)) Then m = m + 1: d1(b(i,
1)) = m: p = m Else p = d1(b(i, 1))
c(p, 1) = b(i, 1): c(p, 3) = b(i, 2)
Next i
Sheets("fusion").[A2].Resize(d1.Count, UBound(c,
2)) = c
End Sub
ou
Sub fusion2()
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
Set f1 = Sheets("ca2014")
a = f1.Range("A2:B" & f1.[a65000].End(xlUp).Row)
Set f2 = Sheets("ca2015")
b = f2.Range("A2:B" & f2.[a65000].End(xlUp).Row)
For i = LBound(a) To UBound(a): d1(a(i, 1)) = "":
d2(a(i, 1)) = "": Next i
For i = LBound(b) To UBound(b): d1(b(i, 1)) = "":
d2(b(i, 1)) = "": Next i
For i = LBound(a) To UBound(a): d1(a(i, 1)) = a(i, 2): Next
i
For i = LBound(b) To UBound(b): d2(b(i, 1)) = b(i, 2): Next
i
Sheets("fusion").[A2].Resize(d1.Count) = Application.Transpose(d1.keys)
Sheets("fusion").[b2].Resize(d1.Count) = Application.Transpose(d1.items)
Sheets("fusion").[c2].Resize(d1.Count) = Application.Transpose(d2.items)
End Sub
Regroupement par lignes avec sous-totaux (tableau + indexation par dictionnaire)
On regroupe les lignes suivant la 1ere colonne en effectuant
un sous total.
On suppose que le tableau Tbl() n'est pas trié.
La table TblRes() est indexée par le dictionnaire
pour permettre un accès plus rapide à chaque ligne de la
table.
Sub RegroupeSousTotall()
Set d1 = CreateObject("Scripting.Dictionary")
Set f1 = Sheets("données")
Tbl = f1.Range("A2:D" & f1.[A65000].End(xlUp).Row).Value
Ncol = 4
Dim TblRes(): ReDim TblRes(1 To UBound(Tbl), 1 To Ncol)
For ligne = 1 To UBound(Tbl)
clé = Tbl(ligne, 1)
If d1.exists(clé) Then
lig = d1(clé)
Else
d1(clé) = d1.Count + 1: lig = d1.Count
' index
For k = 1 To 3: TblRes(lig, k) = Tbl(ligne, k):
Next k
End If
TblRes(lig, 4) = TblRes(lig, 4) + Tbl(ligne, 4)
Next ligne
Set f2 = Sheets("résultats")
f1.[a1].Resize(, Ncol).Copy f2.[a1]
f2.[a2].Resize(d1.Count, Ncol) = TblRes
End Sub
On regroupe les lignes suivant la 1ere colonne en effectuant un sous total et un cacul du nombre de villes distinctes.
Regroupe
Sous Total Nb villes distinctes
Regroupe Sous Total
Nb villes distinctes MAC
Sub RegroupeSousTotallNbVillesDistinctes()
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
Set f1 = Sheets("données")
Tbl = f1.Range("A2:D" & f1.[A65000].End(xlUp).Row).Value
Ncol = 5
Dim TblRes(): ReDim TblRes(1 To UBound(Tbl), 1 To Ncol)
For ligne = 1 To UBound(Tbl)
clé = Tbl(ligne, 1)
If d1.exists(clé) Then
lig = d1(clé)
Else
d1(clé) = d1.Count + 1: lig
= d1.Count ' index
For k = 1 To 2: TblRes(lig, k) = Tbl(ligne,
k): Next k
End If
TblRes(lig, 3) = TblRes(lig, 3) + Tbl(ligne, 4)
clé2 = Tbl(ligne, 1) & "|"
& Tbl(ligne, 3)
If Not d2.exists(clé2) Then
TblRes(lig, 4) = TblRes(lig,
4) + 1
TblRes(lig, 5) = TblRes(lig,
5) & Tbl(ligne, 3) & " ": d2(clé2) = ""
End If
Next ligne
Set f2 = Sheets("résultats")
f2.[a2].Resize(d1.Count, Ncol) = TblRes
End Sub
Autres exemples
Regroupe
Sous Total
Regroupe colonne
avec saut de ligne
Regroupe colonne avec
saut de ligne2
RegroupeSousTotal
Plusieurs champs
RegroupeSousTotal Plusieurs
champs clé 2 colonnes
RegroupeSousTotal
Plusieurs champs 2
RegroupeSousTotal
Plusieurs champs 3
Sub RegroupeLigneCumul()
Set d1 = CreateObject("Scripting.Dictionary")
Set f1 = Sheets("données")
Tbl = f1.[a1].CurrentRegion
Ncol = UBound(Tbl, 2)
Dim TblRes(): ReDim TblRes(1 To UBound(Tbl), 1 To Ncol)
For ligne = 2 To UBound(Tbl)
clé = Tbl(ligne, 1)
If d1.exists(clé) Then lig = d1(clé)
Else d1(clé) = d1.Count + 1: lig = d1.Count ' index
TblRes(lig, 1) = clé
For col = 2 To Ncol
If Tbl(ligne, col) <>
"" Then TblRes(lig, col) = TblRes(lig, col) + Val(Tbl(ligne,
col))
Next col
Next ligne
Set f2 = Sheets("résultats")
f1.[a1].Resize(, Ncol).Copy f2.[a1]
f2.[a2].Resize(d1.Count, Ncol) = TblRes
End Sub
Autre méthode de sous-total avec dictionnaire multicolonnes
Ici, nous effectuons un sous total multi-colonnes dans un dictionnaire.
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
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
Transformation d'un tableau 2D en BD
Sub TransformeT2D_BD()
Set f1 = Sheets("bd")
Set resultat = f1.[H2]
TblE = f1.[B1].CurrentRegion
Dim TblS(): ReDim TblS(1 To UBound(TblE) * UBound(TblE, 2),
1 To 3)
n = 0
For ligne = 2 To UBound(TblE, 1)
For col = 2 To UBound(TblE, 2)
If TblE(ligne, col) <>
"" Then
n = n + 1
TblS(n, 1)
= TblE(ligne, 1)
TblS(n, 2)
= TblE(1, col)
TblS(n, 3)
= TblE(ligne, col)
End If
Next col
Next ligne
resultat.Resize(n, 3) = TblS
End Sub
Statistiques 2 critères
Stat 2 Critères
Totaux
Stat 2 Critères
Totaux MAC
Stat 2 Critères
Totaux Trié
Stat 2 Critères
Maximum
Regroupement
2 Critères Saut de ligne
Sub Stat2DTab()
Set f = Sheets("BD")
TblBD = f.Range("A2:C" & f.[A65000].End(xlUp).Row).Value
' Array pour rapidité
colCrit1 = 1: colCrit2 = 2: colOper = 3
Set Result = f.Range("f1") '
Adresse résultat
Set d1 = CreateObject("Scripting.Dictionary") '
Dictionnaire index pour rapidité
Set d2 = CreateObject("Scripting.Dictionary")
Dim TblTot(): ReDim TblTot(1 To UBound(TblBD), 1 To UBound(TblBD,
2))
Dim TblTotLig(): ReDim TblTotLig(1 To UBound(TblBD))
Dim TblTotCol(): ReDim TblTotCol(1 To UBound(TblBD, 2))
For i = LBound(TblBD) To UBound(TblBD)
clé1 = TblBD(i, colCrit1): If d1.exists(clé1)
Then lig = d1(clé1) Else d1(clé1) = d1.Count + 1: lig =
d1.Count
clé2 = TblBD(i, colCrit2): If d2.exists(clé2)
Then col = d2(clé2) Else d2(clé2) = d2.Count + 1: col =
d2.Count
TblTot(lig, col) = TblTot(lig, col) + TblBD(i,
colOper)
TblTotLig(lig) = TblTotLig(lig) + TblBD(i, colOper)
TblTotCol(col) = TblTotCol(col) + TblBD(i, colOper)
Next i
Result.Offset(1).Resize(d1.Count, 1) = Application.Transpose(d1.keys)
' titre lignes
Result.Offset(, 1).Resize(1, d2.Count) = d2.keys '
titres colonnes
Result.Offset(1, 1).Resize(d1.Count, d2.Count) = TblTot '
stat 2D
Result.Offset(d1.Count + 1, 1).Resize(, d2.Count) = TblTotCol
' totaux colonnes
Result.Offset(1, d2.Count + 1).Resize(d1.Count) = Application.Transpose(TblTotLig)
' totaux lignes
End Sub
Avec des fonctions standards (cf programme)
Sub stats()
tablo = [A2:C11]
a = Stat2DSomme(tablo, 1, 2, 3) '
Adapter avec les colonnes choisies
[F2].Resize(UBound(a), UBound(a, 2)) = a
End Sub
Autre exemple
Rapport croisé
Simul TCD
Sub Stat2DTab()
Set f = Sheets("BD")
TblBD = f.Range("A2:C" & f.[A65000].End(xlUp).Row).Value
' Array pour rapidité
colCrit1 = 1: colCrit2 = 3: colOper = 2
Set AdrResult = f.Range("f1")
' Adresse résultat
Set d1 = CreateObject("Scripting.Dictionary") '
Dictionnaire index pour rapidité
Set d2 = CreateObject("Scripting.Dictionary")
Dim TblRes(1 To 100, 1 To 100)
For i = LBound(TblBD) To UBound(TblBD)
clé1 = TblBD(i, colCrit1): If d1.exists(clé1)
Then lig = d1(clé1) Else d1(clé1) = d1.Count + 1: lig =
d1.Count
clé2 = TblBD(i, colCrit2): If d2.exists(clé2)
Then col = d2(clé2) Else d2(clé2) = d2.Count + 1: col =
d2.Count
TblRes(lig, col) = TblBD(i, colOper)
Next i
AdrResult.Offset(1).Resize(d1.Count, 1) = Application.Transpose(d1.keys)
' titre lignes
AdrResult.Offset(, 1).Resize(1, d2.Count) = d2.keys
' titres colonnes
AdrResult.Offset(1, 1).Resize(d1.Count, d2.Count) = TblRes
' résultat
End Sub
Autre exemple
-La BD est transférée dans une table Tbl(,)
pour la rapidité d'accès.
-Les stats sont effectuées dans un tableau Tstat()
-Pour retrouver plus rapidement la ligne et la colonne du tableau Tstat(,)
où effectuer le cumul, on indexe celui ci avec 2 dictionnaires
d1 et d2
Sub Stat2D()
Set f1 = Sheets("data")
Set d1 = CreateObject("Scripting.Dictionary") '
lignes
Set d2 = CreateObject("Scripting.Dictionary") '
colonnes
Set d3 = CreateObject("Scripting.Dictionary")
Tbl = f1.Range("a2:d" & f1.[A65000].End(xlUp).Row)
Dim Tstat(): ReDim Tstat(1 To UBound(Tbl), 1 To UBound(Tbl,
2) + 1)
Dim Tcol: ReDim Tcol(1 To UBound(Tbl, 2) + 1): Dim Tlig():
ReDim Tlig(1 To UBound(Tbl)) ' totaux lignes & colonnes
For i = 1 To UBound(Tbl)
clé1 = Tbl(i, 1): clé2 = Tbl(i,
3)
If d1.exists(clé1) Then lig = d1(clé1)
Else d3(Tbl(i, 2)) = "": d1(clé1) = d1.Count + 1: lig
= d1.Count
If d2.exists(clé2) Then col = d2(clé2)
Else d2(clé2) = d2.Count + 1: col = d2.Count
Tstat(lig, col) = Tstat(lig, col) + Tbl(i,
4)
Tlig(lig) = Tlig(lig) + Tbl(i, 4)
Tcol(col) = Tcol(col) + Tbl(i, 4)
Next i
Set résult = Sheets("synthèse").Range("a1")
résult.Offset(1).Resize(d1.Count, 1) = Application.Transpose(d1.keys)
' titres lignes
résult.Offset(1, 1).Resize(d3.Count, 1) = Application.Transpose(d3.keys)
résult.Offset(, 2).Resize(1, d2.Count) = d2.keys
' titres colonnes
résult.Offset(1, 2).Resize(d1.Count, d2.Count) = Tstat
résult.Offset(d1.Count + 1, 2).Resize(, d2.Count) =
Tcol
' totaux colonnes
résult.Offset(1, d2.Count + 2).Resize(d1.Count) = Application.Transpose(Tlig)
' totaux lignes
'-- tri lignes
résult.Offset(1).Resize(d1.Count, d2.Count + 3).Sort
key1:=[a2], Header:=xlNo
End Sub
Autre Exemple
On regroupe des icônes en conservant les polices et les couleurs.
Sub RegroupeIcônes()
Set f = Sheets("BD")
BD = f.Range("A2:E" & f.[A65000].End(xlUp).Row).Value
' 2 colonnes de plus pour les attributs
colCrit1 = 1
colCrit2 = 2
colOper = 3
colAttribut = 4
Set AdrRes = f.Range("G1")
' Adresse résultat
For i = LBound(BD) To UBound(BD) '
Remplissage des Attributs
BD(i, colAttribut) = f.Cells(i + 1, colOper).Font.ColorIndex
BD(i, colAttribut + 1) = f.Cells(i + 1, colOper).Font.Name
Next i
AdrRes.CurrentRegion.ClearContents
Set d1 = CreateObject("Scripting.Dictionary")
' Dictionnaire index pour rapidité
Set d2 = CreateObject("Scripting.Dictionary")
For i = LBound(BD) To UBound(BD)
tmp = BD(i, colCrit1): If d1.exists(tmp) Then
lig = d1(tmp) Else d1(tmp) = d1.Count + 1: lig = d1.Count
tmp = BD(i, colCrit2): If d2.exists(tmp) Then
col = d2(tmp) Else d2(tmp) = d2.Count + 1: col = d2.Count
x = Len(AdrRes.Offset(lig, col))
AdrRes.Offset(lig, col).Characters(Start:=x +
1, Length:=1).Text = BD(i, colOper)
AdrRes.Offset(lig, col).Characters(Start:=x +
1, Length:=1).Font.ColorIndex = BD(i, colAttribut)
AdrRes.Offset(lig, col).Characters(Start:=x +
1, Length:=1).Font.Name = BD(i, colAttribut + 1)
Next i
AdrRes.Offset(1).Resize(d1.Count) = Application.Transpose(d1.keys)
' titres lignes
AdrRes.Offset(, 1).Resize(, d2.Count) = d2.keys '
titres colonnes
'--- tri lignes & colonnes
Set Rng = AdrRes.Resize(d1.Count + 1, d2.Count + 1)
Rng.Offset(1).Resize(Rng.Rows.Count - 1, Rng.Columns.Count).Sort
key1:=Rng.Cells(2, 1), _
Order1:=xlAscending, Header:=xlNo, MatchCase:=False,
Orientation:=xlSortColumns
Rng.Offset(, 1).Resize(Rng.Rows.Count, Rng.Columns.Count -
1).Sort key1:=Rng.Cells(1, 2), _
Order1:=xlAscending, Header:=xlNo, MatchCase:=False,
Orientation:=xlSortRows
End Sub
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
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
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
Tri multi zones multi-colonnes
Tri
Multi-colonnes
Tri Multi-colonnes
2 col
Sub TriMC()
Set Rng = Range("A2:A10,C2:C10") ' à adapter
Dim temp()
ReDim temp(Rng.Count)
lig = 0
For i = 1 To Rng.Areas.Count
For j = 1 To Rng.Areas(i).Count
If Rng.Areas(i)(j) <> ""
Then
lig = lig + 1
temp(lig) = Rng.Areas(i)(j)
End If
Next j
Next i
Call Tri(temp, 1, lig)
lig = 0
For i = 1 To Rng.Areas.Count
For j = 1 To Rng.Areas(i).Count
lig = lig + 1
Rng.Areas(i)(j) = temp(lig)
Next j
Next i
End Sub
Autre exemple multi-colonnes
Si le champ C6:C41,I6:I41,O6:O41 a été nommé zonetri, on peut remplacer :
Set Rng1 = Range("C6:C41,I6:I41,O6:O41")
Par
Set Rng1 = Range("zonetri")
Ainsi, les champs peuvent être déplacés.
-La présentation des cellules n'est pas modifiée.
Seul le contenu est modifié.
-Les cellules au dessous du tableau peuvent être utilisées
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 par
date
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
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 Tableau
2D 3 Critères Index
Tri Tableau
2D 3 Critères Asc/Desc Index
Tri
Tableau 2D 3 Critères Asc/Desc H2So4 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).
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
Fonctions de tri d'une BD
Ces fonctions donnent une version triée d'une BD
-sélectionner A2:H18
=TriBD(BD;{1;2;3;4;5;6;7;8};1)
-valider avec maj+ctrl+entrée
-sélectionner A2:H18
=TriBD(BD;{1;2;3;4;5;6;7;8};1;2;3)
-valider avec maj+ctrl+entrée
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
Tri ligne
par ligne d'un Array
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.
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.
Tri d'un Array 1 dimension à l'aide du tableur
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
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
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
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.
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.
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.
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.
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
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)
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
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.
Différence entre 2 tableaux 2D: c()=a()-b()
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
Join ne fonctionne que pour des Arrays à 1 dimension. Pour les Arrays multi-dimensions
Sub essai()
Tbl = [A1:D1000]
temp = JoinArray(Tbl, ",")
End Sub
Function JoinArray(Tbl, Sep)
For Each c In Tbl
temp = temp & c & Sep
Next c
JoinArray = Left(temp, Len(temp) - 1)
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
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
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
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
Synthèses 3D
Cette fonction perso matricielle calcule
la somme de plusieurs onglets suivant 2 critères.
-Les listes des codes et des villes sont obtenues et triées automatiquement
par la fonction.
-Cette fonction est rapide: grâce à Dictionary,
la recherche de la ligne et de la colonne du tableau de cumul Tbl() se
fait très rapidement.
Fonction
Somme3D 2 critères
Fonction Somme3D
2 critères2
Fonction Somme3D
2 critères MAC
Fonction Somme3D 1
col Num
Fonction
Somme3D N col Num
Fonction
Somme3D N col Num Index
Fonction
Somme3D N col Num MAC
Fonction
Somme3D N col Num IndexMAC
-Sélectionner A1:E10
=S3DTriée(1;3; "a2:a20";"b2:b20"; "c2:c20")
-valider avec maj+ctrl+entrée
Function S3DTriée(début, fin, critLigne, CritColonne,
ChampSomme)
Application.Volatile
Dim Tbl()
ReDim Tbl(0 To Application.Caller.Rows.Count, 0 To Application.Caller.Columns.Count)
Set dLig = CreateObject("Scripting.Dictionary")
Set dCol = CreateObject("Scripting.Dictionary")
For s = début To fin
a = Sheets(s).Range(critLigne).Value
b = Sheets(s).Range(CritColonne).Value
For i = LBound(a) To UBound(a)
If a(i, 1) <> "" Then
If Not dLig.exists(a(i, 1)) Then dLig(a(i, 1)) = ""
If b(i, 1) <> "" Then
If Not dCol.exists(b(i, 1)) Then dCol(b(i, 1)) = ""
Next i
Next s
crit1 = dLig.keys: Call Tri(crit1, LBound(crit1), UBound(crit1))
dLig.RemoveAll: For i = 0 To UBound(crit1): dLig(crit1(i))
= i + 1: Next
lig = 1: For Each c In dLig.keys: Tbl(lig, 0) = c: lig = lig
+ 1: Next c
crit1 = dCol.keys: Call Tri(crit1, LBound(crit1), UBound(crit1))
dCol.RemoveAll: For i = 0 To UBound(crit1): dCol(crit1(i))
= i + 1: Next
k = 1: For Each c In dCol.keys: Tbl(0, k) = c: k = k + 1:
Next c
For s = début To fin
idxLig = Sheets(s).Range(critLigne).Value
idxCol = Sheets(s).Range(CritColonne).Value
a = Sheets(s).Range(ChampSomme).Value
For lig = LBound(a) To UBound(a)
cléLig = CStr(idxLig(lig, 1)):
clécol = idxCol(lig, 1)
If cléLig <> ""
And clécol <> "" Then
ligtbl = dLig(cléLig):
coltbl = dCol(clécol)
Tbl(ligtbl, coltbl) =
Tbl(ligtbl, coltbl) + a(lig, 1)
End If
Next lig
Next s
S3DTriée = Tbl
End Function
Autre version
Somme3D
2 critères
Somme3D 2
critères MAC
-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é
Sub RechercheDicho()
Tbl = [A1:B60000]
valCherchée = "Nom00007"
retour = Dicho(Tbl, valCherchée, 2)
MsgBox retour
End Sub
Function Dicho(Tbl, valCherchée, Colretour)
Inf = 1: Sup = UBound(Tbl): Position = 0
Do
If Inf > Sup Then
Position = -1
Else
milieu = (Inf + Sup) \ 2
If valCherchée < Tbl(milieu,
1) Then
Sup = milieu - 1
Else
If valCherchée
> Tbl(milieu, 1) Then Inf = milieu + 1 Else Position = milieu
End If
End If
Loop While Position = 0
If Position <> -1 Then Dicho = Tbl(Position, Colretour)
Else Dicho = -1
End Function
Si on effectue une recherche sur une valeur exacte,
dictionary est sensiblement plus rapide.
Pour un positionnement sur la valeur inférieure si élément
non trouvé:
Recherche
Dichotomique 2
Recherche Dichotomique
3
Function Dicho(Tbl, valCherchée, Colretour, VraiFaux)
inf = 1: sup = UBound(Tbl): Position = 0
Do
If inf > sup Then
Position = -1
Else
milieu = (inf + sup) \ 2
If valCherchée < Tbl(milieu,
1) Then
sup = milieu - 1
Else
If valCherchée
> Tbl(milieu, 1) Then inf = milieu + 1 Else Position = milieu
End If
End If
Loop While Position = 0
If Position <> -1 Then
Dicho = Tbl(Position, Colretour)
Else
If VraiFaux Then
Dicho = Tbl(sup, Colretour)
Else
Dicho = -1
End If
End If
End Function
-Sur un champ, on peut également utiliser retour=VlookUp(valeurCherchée,champ,ColRésultat,True)
-Sur un Array(), on peut utiliser : retour = Application.VLookup(valCherchée,
Tbl, 2, True) mais le temps d'exécution est très
mauvais (comme pour Application.Match sur un Array())
Conversion tableau 1D en tableau 2D
Conversion Array 1D en Array 2D
Sub ConvTabMultCol()
Set f = Sheets("bd")
Set Rng = f.Range("a2:a" & f.[a65000].End(xlUp).Row)
bd = Application.Transpose(Rng.Value)
n = Rng.Count
hauteur = 10
largeur = n \ hauteur + 1
Dim Tbl(): ReDim Tbl(1 To hauteur, 1 To largeur)
For i = 1 To n
k = (i - 1) \ hauteur + 1
j = i - hauteur * (k - 1)
Tbl(j, k) = bd(i)
Next i
[C2].Resize(hauteur, largeur) = Tbl
End Sub
Position d'un item dans un Array
Recherche position item dans un Array
Sub Essai()
Tbl = [{11,12,13;21,22,23;31,32,33;41,42,43}] ' Array avec
4 lignes et 3 colonnes
MsgBox RechPositionElement(Tbl, 13)
MsgBox RechPositionElement(Tbl, 32)
End Sub
Function RechPositionElement(Tbl, valCherchée)
For lig = 1 To UBound(Tbl)
For col = 1 To UBound(Tbl, 2)
If Tbl(lig, col) = valCherchée
Then RechPositionElement = "Ligne:" & lig & "/Colonne:"
& col: Exit Function
Next col
Next lig
End Function
Recherche de plusieurs mots clés dans un libellé
Recherche
plusieurs mots clés dans un libellé
Recherche plusieurs
mots clés dans un libellé tableau
Fusion de 2 Arrays une dimension
Sub EssaiFusionTBl()
Set f = Sheets("feuil1")
Tbl1 = Application.Transpose(f.Range("a2:a" &
f.[A65000].End(xlUp).Row))
Tbl2 = Application.Transpose(f.Range("b2:b" &
f.[b65000].End(xlUp).Row))
Tbl3 = FusionTbl(Tbl1, Tbl2)
End Sub
Function FusionTbl(a, b)
Set d = CreateObject("scripting.dictionary")
For i = 1 To UBound(a): d(a(i)) = "": Next i
For i = 1 To UBound(b): d(b(i)) = "": Next i
FusionTbl = d.keys
End Function
Synthèse d'un tableau
Sub Synthese()
TblImpact = [A2].CurrentRegion.Value: TblBD = [A4].CurrentRegion.Value
Dim TblRes(): ReDim TblRes(1 To UBound(TblBD), 1 To 2)
n = 0
For k = 2 To UBound(TblImpact, 2)
If TblImpact(1, k) = "oui" Then
For i = 2 To UBound(TblBD)
If TblBD(i, k) =
"x" Then n = n + 1: TblRes(n, 1) = TblBD(1, k): TblRes(n, 2)
= TblBD(i, 1)
Next i
End If
Next k
[H2].Resize(n, 2) = TblRes
End Sub
Complément Array : result=a()-b()
a() contient les dates d'un mois. b() contient des dates de ce mois. On veut les dates de a() qui ne sont pas dans b().
Sub EssaiComplémentArray()
'-- simulation a() et b()
....
....
'--- Complément result=a()-b()
Result = ComplementArray(a, b)
[A1].Resize(, UBound(Result) + 1) = Result
End Sub
Function ComplementArray(a, b)
Set d1 = CreateObject("scripting.dictionary")
For Each c In b: d1(c) = "": Next c
Set d2 = CreateObject("scripting.dictionary")
For Each c In a
If Not d1.exists(c) Then d2(c) = ""
Next c
ComplementArray = d2.keys
End Function
Fonction TblMaxi(Tbl,col)
Sub essai()
Tbl = [A1:B200000].Value
maxi = TblMax(Tbl, 2)
End Sub
Function TblMax(Tbl, col)
maxi = Tbl(LBound(Tbl) + 1, col)
For i = LBound(Tbl) To UBound(Tbl)
If Tbl(i, col) > maxi Then maxi = Tbl(i, col)
Next i
TblMax = maxi
End Function
Exemples divers
Regroupe
Sous Total Nb villes distinctes MAC
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
Statistiques avec Dictionnaire
Transfert
de tableau vers tableau
Transfert de tableau
2 lignes vers tableau 1 ligne
Recherche BD 3
groupes
Exemples |
Arrays
Synthèse |