Le but de ces codes est de réaliser certaines fonctionnalités (filtre, tri, etc) d'excel, en ne travaillant qu'en mémoire vive et pas sur les cellules. Cela permet un gain de temps pour vos procédures et macros.
Ces fonctions sont prêtes à l'emploi. Cependant, si vous y dénichez des erreurs (et je ne doute pas qu'il y en ait), merci de bien vouloir me les signaler par messagerie privée ou sur le forum.
Je vous recommande de placer toutes ces fonctions et procédures dans un module. Ainsi elles pourront être facilement mises à disposition dans chacun de vos classeurs. Un module complet est à votre disposition au paragraphe téléchargement.
Pour ne pas refaire ce qui existe et a été très bien réalisé, je vous recommande cette lecture afin de vous familiariser avec les variables tableaux et la syntaxe qui va avec...
Ajouter un Index à un tableau
Ajoute un élément (ou une ligne d'éléments) à un array (1 ou 2 dimensions) et lui attribue un index précis.
Retourne True si tout s'est bien passé, False et un message d'erreur explicit dans le cas contraire.
Tableau : doit être déclaré comme Variant, pas comme une variable tableau donc sans les parenthèses. exemple : Dim monTab ou Dim MyTbl As Variant
Index : doit être compris entre le premier indice du Tableau et le dernier indice + 1
Textos :
en cas de Tableau à 1 dimension ne doit pas être un Array ==> 1 seule valeur, ex : Texte = "toto"
en cas de Tableau à 2 dimensions doit être un Array ==> ex : Textes = Array("toto", "titi", "tata")
Public Function Ajoute_Index(ByRef Tableau As Variant, _
Index As Long, _
Textos As Variant) As Boolean
Ajoute_Index = False
If Index < LBound(Tableau) Or Index > UBound(Tableau) + 1 Then GoTo Erreur_Index
Select Case Nb_Dimensions(Tableau)
Case 1
'===== le présent code, déposé par ucfoutu sur VBFrance, est la seule propriété de VBFrance
'=====VBFrance en autorise les libres copie et utilisation à la seule condition d'y laisser
'=====insérées les trois présentes lignes commentées
'solution sans ReDim ni Preserve
If Nb_Dimensions(Textos) > 0 Then GoTo Erreur_Textos
If Index = UBound(Tableau) + 1 Then
Tableau(Index - 1) = Tableau(Index - 1) & Chr(0) & Chr(0)
Else
Tableau(Index) = Chr(0) & Chr(0) & Tableau(Index)
End If
Dim Tbl
On Error GoTo Erreur_Tableau
Tbl = Split(Replace(Join(Tableau, Chr(0)), Chr(0) & Chr(0), Chr(0)), Chr(0))
Tbl(Index) = Textos
Tableau = Tbl
'=========================
On Error GoTo 0
Erase Tbl
Ajoute_Index = True
Case 2
If Nb_Dimensions(Textos) = 1 Then
Dim tabl(), j As Long, i As Long
'solution avec ReDim et Preserve
On Error GoTo Erreur_Tableau
ReDim Preserve tabl(LBound(Tableau, 1) To UBound(Tableau, 1) + 1, LBound(Tableau, 2) To UBound(Tableau, 2))
For i = LBound(Tableau, 1) To Index - 1
For j = LBound(Tableau, 2) To UBound(Tableau, 2)
tabl(i, j) = Tableau(i, j)
Next
Next
For i = Index To UBound(Tableau, 1)
For j = LBound(Tableau, 2) To UBound(Tableau, 2)
tabl(i + 1, j) = Tableau(i, j)
Next
Next
For j = LBound(Textos) To UBound(Textos)
tabl(Index, j + 1) = Textos(j)
Next
Tableau = tabl
On Error GoTo 0
Erase tabl
Ajoute_Index = True
Else
GoTo Erreur_Textos
End If
Case Else
MsgBox "Votre Tableau ne comporte pas le nombre de dimension adéquat. Fonction non traitée."
End Select
Exit Function
Erreur_Tableau:
MsgBox "Votre Tableau n'a pas été déclaré comme il convient."
Exit Function
Erreur_Textos:
MsgBox "Le dernier paramètre de la fonction n'est pas valide."
Exit Function
Erreur_Index:
MsgBox "Index non valide"
End Function
Extraire une Colonne à un tableau
Va créer une variable tableau à une dimension à partir d'une variable tableau multidimensionnelle, en extrayant les données d'une colonne de ce tableau.
Retourne donc une variable tableau de type Variant à une dimension.
Attention :
utilise la fonction : Nb_Dimensions
Paramètres :
Tableau = Array de variant à 2 dimensions
Colonne = numéro de la colonne contenant les données à extraire
Public Function Extrait_Colonne(ByVal Tableau As Variant, _
Colonne As Long) As Variant
Dim Tbl() As Variant, i As Long, TestColonne As Variant
On Error GoTo Erreur_Colonne
TestColonne = Tableau(LBound(Tableau, 1), Colonne)
On Error GoTo 0
Select Case Nb_Dimensions(Tableau)
Case 0
MsgBox "Le tableau passé en paramètre est vide.": Exit Function
Case 1
MsgBox "Le tableau passé en paramètre ne comporte qu'une colonne."
Exit Function
Case 2
ReDim Tbl(UBound(Tableau, 1))
For i = LBound(Tableau, 1) To UBound(Tableau, 1)
Tbl(i) = Tableau(i, Colonne)
Next
End Select
Extrait_Colonne = Tbl
Erase Tbl
Exit Function
Erreur_Colonne:
MsgBox "Le paramètre Colonne est erroné."
End Function
Filtrer une variable tableau
Filtre un tableau à 2 dimensions en fonction du contenu d'une colonne.
Retourne un tableau à 2 dimensions de type Variant.
Attention :
utilise les fonctions : Nb_Dimensions & Transposition & Retourne_Colonne
Paramètres :
Tableau = Array de variant à 2 dimensions
Item = Au choix : numéro de la colonne ou valeur à chercher dans le tableau
Key1 = comparateur, donnée à laquelle comparer les données de la colonne Colonne
Test = opérateur parmi : "=", "<", "<=", ">", ">=", "Like", "<>" (à passer en String donc avec guillemets)
Public Function Filtre_Tableau(ByVal Tableau As Variant, _
Item As Variant, _
Key1 As Variant, _
Optional test As String = "=") As Variant
Dim Tbl() As Variant, i As Long, j As Long, Cpt As Long, Colonne As Long, TestColonne As Variant
Select Case VarType(Item)
Case 8: Colonne = Retourne_Colonne(Tableau, Item)
Case 2, 3, 17: Colonne = CLng(Item)
Case Else: GoTo Erreur_Colonne
End Select
On Error GoTo Erreur_Colonne
TestColonne = Tableau(LBound(Tableau, 1), Colonne)
On Error GoTo 0
Select Case Nb_Dimensions(Tableau)
Case 0
MsgBox "Le tableau passé en paramètre est vide.": Exit Function
Case 1
MsgBox "Le tableau passé en paramètre ne comporte qu'une colonne."
Exit Function
Case 2
If IsDate(Key1) Then Key1 = CDate(Key1)
If IsNumeric(Key1) Then Key1 = CLng(Key1)
Select Case test
Case "="
For i = LBound(Tableau, 1) To UBound(Tableau, 1)
If Tableau(i, Colonne) = Key1 Then
Cpt = Cpt + 1
ReDim Preserve Tbl(LBound(Tableau, 2) To UBound(Tableau, 2), LBound(Tableau, 1) To Cpt)
For j = LBound(Tableau, 2) To UBound(Tableau, 2)
Tbl(j, Cpt) = Tableau(i, j)
Next j
End If
Next i
Case "<"
For i = LBound(Tableau, 1) To UBound(Tableau, 1)
If Tableau(i, Colonne) < Key1 Then
Cpt = Cpt + 1
ReDim Preserve Tbl(LBound(Tableau, 2) To UBound(Tableau, 2), LBound(Tableau, 1) To Cpt)
For j = LBound(Tableau, 2) To UBound(Tableau, 2)
Tbl(j, Cpt) = Tableau(i, j)
Next j
End If
Next i
Case ">"
For i = LBound(Tableau, 1) To UBound(Tableau, 1)
If Tableau(i, Colonne) > Key1 Then
Cpt = Cpt + 1
ReDim Preserve Tbl(LBound(Tableau, 2) To UBound(Tableau, 2), LBound(Tableau, 1) To Cpt)
For j = LBound(Tableau, 2) To UBound(Tableau, 2)
Tbl(j, Cpt) = Tableau(i, j)
Next j
End If
Next i
Case "<="
For i = LBound(Tableau, 1) To UBound(Tableau, 1)
If Tableau(i, Colonne) <= Key1 Then
Cpt = Cpt + 1
ReDim Preserve Tbl(LBound(Tableau, 2) To UBound(Tableau, 2), LBound(Tableau, 1) To Cpt)
For j = LBound(Tableau, 2) To UBound(Tableau, 2)
Tbl(j, Cpt) = Tableau(i, j)
Next j
End If
Next i
Case ">="
For i = LBound(Tableau, 1) To UBound(Tableau, 1)
If Tableau(i, Colonne) >= Key1 Then
Cpt = Cpt + 1
ReDim Preserve Tbl(LBound(Tableau, 2) To UBound(Tableau, 2), LBound(Tableau, 1) To Cpt)
For j = LBound(Tableau, 2) To UBound(Tableau, 2)
Tbl(j, Cpt) = Tableau(i, j)
Next j
End If
Next i
Case "<>"
For i = LBound(Tableau, 1) To UBound(Tableau, 1)
If Tableau(i, Colonne) <> Key1 Then
Cpt = Cpt + 1
ReDim Preserve Tbl(LBound(Tableau, 2) To UBound(Tableau, 2), LBound(Tableau, 1) To Cpt)
For j = LBound(Tableau, 2) To UBound(Tableau, 2)
Tbl(j, Cpt) = Tableau(i, j)
Next j
End If
Next i
Case "Like"
For i = LBound(Tableau, 1) To UBound(Tableau, 1)
If Tableau(i, Colonne) Like Key1 Then
Cpt = Cpt + 1
ReDim Preserve Tbl(LBound(Tableau, 2) To UBound(Tableau, 2), LBound(Tableau, 1) To Cpt)
For j = LBound(Tableau, 2) To UBound(Tableau, 2)
Tbl(j, Cpt) = Tableau(i, j)
Next j
End If
Next i
Case Else
MsgBox "Le paramètre facultatif Test est erroné."
Exit Function
End Select
On Error GoTo resultat_Vide
TestColonne = Tbl(UBound(Tbl, 1), UBound(Tbl, 2))
On Error GoTo 0
Filtre_Tableau = Transposition(Tbl)
Erase Tbl
Case Else
MsgBox "Le tableau comporte plus de deux dimensions. La fonction n'est pas adaptée à ce cas."
End Select
Exit Function
Erreur_Colonne:
MsgBox "Le paramètre Item est erroné."
Exit Function
resultat_Vide:
MsgBox "Le filtre renvoie un tableau vide de données."
End Function
Inverser une variable tableau
Inverse les éléments d'un tableau (1 ou 2 dimensions). Les premiers seront les derniers!
Retourne True si tout va bien et False + un message dans le cas contraire.
A lire : Source
Attention :
utilise la fonction : Nb_Dimensions
Paramètre :
Tableau = Array de Variant à 1 ou 2 dimensions
Public Function Inverse_Tableau(ByRef Tableau As Variant) As Boolean
Dim Temp As Variant, IndexDeb As Long, IndexFin As Long, IndexDim2 As Long
Inverse_Tableau = False
Select Case Nb_Dimensions(Tableau)
Case 0
MsgBox "Le tableau passé en paramètre est vide."
Case 1
IndexFin = UBound(Tableau)
For IndexDeb = LBound(Tableau) To ((UBound(Tableau) - LBound(Tableau) + 1) \ 2)
Temp = Tableau(IndexDeb)
Tableau(IndexDeb) = Tableau(IndexFin)
Tableau(IndexFin) = Temp
IndexFin = IndexFin - 1
Next IndexDeb
Inverse_Tableau = True
Case 2
IndexFin = UBound(Tableau, 1)
For IndexDeb = LBound(Tableau, 1) To ((UBound(Tableau, 1) - LBound(Tableau, 1) + 1) \ 2)
For IndexDim2 = LBound(Tableau, 2) To UBound(Tableau, 2)
Temp = Tableau(IndexDeb, IndexDim2)
Tableau(IndexDeb, IndexDim2) = Tableau(IndexFin, IndexDim2)
Tableau(IndexFin, IndexDim2) = Temp
Next IndexDim2
IndexFin = IndexFin - 1
Next IndexDeb
Inverse_Tableau = True
Case Else
MsgBox "Le tableau comporte plus de deux dimensions."
End Select
End Function
Nombre de dimensions d'un tableau
Calcule le nombre de dimensions d'un tableau.
Retourne un Integer
Paramètre :
Tableau = Array de Variant à 0, 1 ou plusieurs dimensions
Public Function Nb_Dimensions(Tableau As Variant) As Integer
Dim D As Integer, t As Long
On Error GoTo Fin
Do: D = D + 1: t = UBound(Tableau, D): Loop
Fin:
Nb_Dimensions = D - 1
End Function
Passer les valeurs d'un Range au tableau
Converti sans faille un range en tableau. Pallie le problème rencontré si le Range ne contient qu'une cellule.
A lire : Source.
Retourne un tableau, toujours en option base 1 et à 2 dimensions
Paramètre :
plage = Range (plage de cellule(s))
Public Function Range_To_Tb(Plage As Range) As Variant()
If Plage.Cells.Count < 2 Then
Dim tablo(1 To 1, 1 To 1)
tablo(1, 1) = Plage.Value
Range_To_Tb = tablo
Erase tablo
Else
Range_To_Tb = Plage.Value
End If
End Function
Déterminer le numéro de colonne dans un tableau
Détermine le numéro de colonne d'un élément dans un tableau à 2 dimensions.
Retourne un Long représentant le numéro de colonne de cet élément, -1 si l'élément n'existe pas dans le tableau.
Attention :
utilise la fonction : Nb_Dimensions
Paramètres :
Tableau = Array de Variant à 2 dimensions
Texto = Donnée de type Variant à chercher dans le tableau
Public Function Retourne_Colonne(ByRef Tableau As Variant, _
Texto As Variant) As Long
Dim i As Long, j As Integer
Retourne_Colonne = -1
Select Case Nb_Dimensions(Tableau)
Case 0
MsgBox "Le tableau passé en paramètre est vide."
Case 1
MsgBox "Le tableau passé en paramètre n'a qu'une dimension"
Case 2
For i = LBound(Tableau, 1) To UBound(Tableau, 1)
For j = LBound(Tableau, 2) To UBound(Tableau, 2)
If Tableau(i, j) = Texto Then Retourne_Colonne = j: Exit Function
Next j
Next i
Case Else
MsgBox "Le tableau comporte plus de deux dimensions."
End Select
End Function
Déterminer l'index d'un élément dans un tableau
Détermine l'index d'un élément à partir de son contenu
Retourne un Long représentant l'index de cet élément, -1 si l'élément n'existe pas dans le tableau.
Texto = Donnée de type String à chercher dans le tableau à la colonne Colonne
Optional Colonne => indique la colonne du tableau ou chercher la valeur Texto
Public Function Retourne_Index(ByVal Tableau As Variant, _
Texto As String, _
Optional Colonne As Long = 1) As Long
Dim i As Long, strTemp As String
Retourne_Index = -1
Select Case Nb_Dimensions(Tableau)
Case 0
MsgBox "Le tableau passé en paramètre est vide."
Case 1
'===== le présent code, déposé par ucfoutu sur VBFrance, est la seule propriété de VBFrance
'=====VBFrance en autorise les libres copie et utilisation à la seule condition d'y laisser
'=====insérées les trois présentes lignes commentées
strTemp = Chr(0) & Join(Tableau, Chr(0)) & Chr(0)
i = InStr(strTemp, Chr(0) & Texto & Chr(0))
If i = 0 Then Retourne_Index = -1: Exit Function
strTemp = Mid(strTemp, 1, i)
Retourne_Index = UBound(Split(strTemp, Chr(0))) - 1
If Retourne_Index < 0 Then Retourne_Index = -1
Exit Function
'======================
Case 2
For i = LBound(Tableau, 1) To UBound(Tableau, 1)
If Tableau(i, Colonne) = Texto Then Retourne_Index = i: Exit Function
Next i
End Select
End Function
Supprimer un élément dans un tableau
Supprime un élément (ou une ligne d'éléments) par son index ou par son contenu
Retourne un tableau de type Variant.
Attention :
utilise les fonctions : Retourne_Index & Nb_Dimensions
Text_Ou_Index = Donnée de type Variant (String ("mot" à chercher) ou Long (Index du "mot" à chercher)), à chercher dans le tableau
Optional Colonne => Cas d'un array à 2 dimensions : indique la colonne du tableau ou chercher la valeur Text_Ou_Index
Public Function Supprime_Index(ByRef Tableau As Variant, _
Text_Ou_Index, _
Optional Colonne As Long = 1) As Variant
Dim i As Long, Sucf As String
If VarType(Text_Ou_Index) = 8 Then
Sucf = Text_Ou_Index
i = Retourne_Index(Tableau, Sucf, Colonne)
Else
i = Text_Ou_Index
End If
If i >= 0 Then
Select Case Nb_Dimensions(Tableau)
Case 0
MsgBox "Le tableau passé en paramètre est vide."
Case 1
'===== le présent code, déposé par ucfoutu sur VBFrance, est la seule propriété de VBFrance
'=====VBFrance en autorise les libres copie et utilisation à la seule condition d'y laisser
'=====insérées les trois présentes lignes commentées
Tableau(i) = ""
Sucf = Join(Tableau, Chr(0))
If i = 0 Then Sucf = Mid(Sucf, 2)
If i = UBound(Tableau) Then Sucf = Left(Sucf, Len(Sucf) - 1)
Supprime_Index = Split(Replace(Sucf, Chr(0) & Chr(0), Chr(0)), Chr(0))
'==================
Case 2
Dim j As Long, k As Long, Cpt As Long, Tbl
For j = LBound(Tableau, 1) To UBound(Tableau, 1) - 1
If j <> i Then
For k = LBound(Tableau, 2) To UBound(Tableau, 2)
Cpt = Cpt + 1
ReDim Preserve Tbl(1 To Cpt, 1 To k)
Tbl(Cpt, k) = Tableau(j + 1, k)
Next k
End If
Next j
Supprime_Index = Tbl
Erase Tbl
Case Else
MsgBox "Le tableau comporte plus de deux dimensions. La fonction n'est pas adaptée à ce cas."
End Select
Else
MsgBox "La valeur à supprimer n'a pas été trouvée dans la variable tableau"
End If
End Function
Transposer une variable tableau
La fonction Excel Transpose (ou en VBA Application.Transpose) est limitée à 65536 lignes. Cette fonction pallie ce manque pour les grandes variables tableaux.
Retourne un tableau de type Variant.
Attention :
utilise la fonction : Nb_Dimensions
Paramètre :
Tableau = Array de Variant
Public Function Transposition(ByRef Tableau As Variant) As Variant
Dim tabl, i As Long, j As Long
Select Case Nb_Dimensions(Tableau)
Case 0
MsgBox "Le tableau passé en paramètre est vide."
Case 1
ReDim tabl(LBound(Tableau) To UBound(Tableau), LBound(Tableau) To 1)
For i = LBound(Tableau) To UBound(Tableau)
tabl(i, LBound(Tableau)) = Tableau(i)
Next
Transposition = tabl
Erase tabl
Case 2
ReDim tabl(LBound(Tableau, 2) To UBound(Tableau, 2), LBound(Tableau, 1) To UBound(Tableau, 1))
For i = LBound(Tableau, 1) To UBound(Tableau, 1)
For j = LBound(Tableau, 2) To UBound(Tableau, 2)
tabl(j, i) = Tableau(i, j)
Next j
Next i
Transposition = tabl
Erase tabl
Case Else
MsgBox "Le tableau comporte plus de deux dimensions"
End Select
End Function
Tri d'un tableau à 1 dimension
Tri un tableau à 1 dimension.
Retourne le tableau de Variant passé en paramètre, trié.
Basé sur le QuickSort de Boisgontier : http://boisgontierjacques.free.fr/
Paramètres :
Tableau = Array de Variant
mini = indice inférieur (ex : LBound(Tableau))
Maxi = indice supérieur (ex : UBound(Tableau))
Public Sub Tri_1_Dim(ByRef Tableau As Variant, _
mini As Long, _
Maxi As Long)
Dim i As Long, j As Long, Pivot As Variant, Temp As Variant
On Error Resume Next
i = mini: j = Maxi
Pivot = Tableau((mini + Maxi) \ 2)
While i <= j
While Tableau(i) < Pivot And i < Maxi: i = i + 1: Wend
While Pivot < Tableau(j) And j > mini: j = j - 1: Wend
If i <= j Then
Temp = Tableau(i)
Tableau(i) = Tableau(j)
Tableau(j) = Temp
i = i + 1: j = j - 1
End If
Wend
If (mini < j) Then Call Tri_1_Dim(Tableau, mini, j)
If (i < Maxi) Then Call Tri_1_Dim(Tableau, i, Maxi)
End Sub
Tri d'un tableau à 2 dimensions
Tri un tableau à deux dimensions.
Retourne le tableau de Variant passé en paramètre, trié selon la colonne donnée en paramètre.
A lire : Source
Paramètres :
Tableau = Array de Variant
mini = indice inférieur (ex : LBound(Tableau))
Maxi = indice supérieur (ex : UBound(Tableau))
Optional Colonne = la colonne selon laquelle trier le tableau
Public Sub Tri_2_Dim(ByRef Tableau As Variant, _
mini As Long, _
Maxi As Long, _
Optional Colonne As Long = 0)
Dim i As Long, j As Long, Pivot As Variant, TableauTemp As Variant, ColTemp As Long
On Error Resume Next
i = mini: j = Maxi
Pivot = Tableau((mini + Maxi) \ 2, Colonne)
While i <= j
While Tableau(i, Colonne) < Pivot And i < Maxi: i = i + 1: Wend
While Pivot < Tableau(j, Colonne) And j > mini: j = j - 1: Wend
If i <= j Then
ReDim TableauTemp(LBound(Tableau, 2) To UBound(Tableau, 2))
For ColTemp = LBound(Tableau, 2) To UBound(Tableau, 2)
TableauTemp(ColTemp) = Tableau(i, ColTemp)
Tableau(i, ColTemp) = Tableau(j, ColTemp)
Tableau(j, ColTemp) = TableauTemp(ColTemp)
Next ColTemp
Erase TableauTemp
i = i + 1: j = j - 1
End If
Wend
If (mini < j) Then Call Tri_2_Dim(Tableau, mini, j, Colonne)
If (i < Maxi) Then Call Tri_2_Dim(Tableau, i, Maxi, Colonne)
End Sub
Téléchargement
Vous trouverez ICI, un module regroupant toutes ces fonctions.
Pour l'intégrer à votre classeur après l'avoir téléchargé :
Sous VBE : Fichier/Importer un fichier
Bonne utilisation.
Cet article est régulièrement mis à jour par des experts sous la direction de Jean-François Pillou, fondateur de CommentCaMarche et directeur délégué au développement numérique du groupe Figaro.
