Objectif : Rassembler les données d'une ou plusieurs feuilles de calculs selon un ou plusieurs critères.
Un userform avec une liste "Listbox1" et un bouton "BoutonOk.
Une feuille de calculs contenant 6 colonnes renseignées (sinon modifier NbCol)
Exemple pour une feuille :
Appel :
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
Sub BoutonOk_Click()
Dim NbCol as byte
    NbCol = 6
    ChercherDansUneFeuille Textbox1, Textbox2, NbCol 
End sub
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
Sub ChercherDansUneFeuille(Critère1 As Variant, Critère2 As Variant, NbCol as Byte)
Dim Feuille As Worksheet, Cell As Range, addDeb As String
Dim Tablo() As Variant, i as integer, j as integer
    ListBox3.ColumnCount = NbCol
    Set Feuille = Worksheets("feuil1")
    With Feuille.Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
        Set Cell = .Find(Critère1, LookIn:=xlValues, lookat:=xlPart)
        If Not Cell Is Nothing Then
            addDeb = Cell.Address
            Do
                If Cell.Offset(0, 5) = Critère2 Then
                    i = i + 1
                    ReDim Preserve Tablo(NbCol, i)
                    For j = 0 To NbCol - 1
                        Tablo(j, i) = Cell.Offset(0, j)
                    Next
                End If
                Set Cell = .FindNext(Cell)
            Loop While Not Cell Is Nothing And Cell.Address <> addDeb
         End If
    End With
    For i = 1 To UBound(Tablo)
    Next
    Me.ListBox1.List = Application.Transpose(Tablo)
End Sub
La même procédure s'appliquant à plusieurs feuilles
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
Sub BoutonOk_Click()
Dim NbCol as byte
    NbCol = 6
    ChercherDansPlusieursFeuille Textbox1, Textbox2, NbCol 
End sub
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
Sub ChercherDansPlusieursFeuille(Critère1 As Variant, Critère2 As Variant, NbCol As Byte)
Dim Feuille As Worksheet, Cell As Range, addDeb As String
Dim Tablo() As Variant
    ListBox3.ColumnCount = NbCol
    For Each Feuille In ThisWorkbook.Worksheets
        If InStr(Feuille.Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).Address, ":") = 0 Then Exit Sub
        With Feuille.Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
            Set Cell = .Find(Critère1, LookIn:=xlValues, lookat:=xlPart)
            If Not Cell Is Nothing Then
                addDeb = Cell.Address
                Do
                    If Cell.Offset(0, 5) = Critère2 Then
                        i = i + 1
                        ReDim Preserve Tablo(NbCol, i)
                        For j = 0 To NbCol - 1
                            Tablo(j, i) = Cell.Offset(0, j)
                        Next
                    End If
                    Set Cell = .FindNext(Cell)
                Loop While Not Cell Is Nothing And Cell.Address <> addDeb
             End If
        End With
    Next Feuille
    Me.ListBox1.List = Application.Transpose(Tablo)
End Sub
Le code ci-dessus concerne plusieurs colonnes contigues de la feuille ce calculs.
Pour plusieurs colonnes non contigues de la feuille de calculs, il est nécessaire d'affecter les valeurs indépendamment pour chaque colonne de la liste en remplaçant la boucle de recherche comme suit
(Feuille de calculs comportant 10 colonnes renseignées ou plus)
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
            Do
                If Cell.Offset(0, 5) = Critère2 Then
                    i = i + 1
                    ReDim Preserve Tablo(NbCol, i)
                        Tablo(0, i) = Cell
                        Tablo(1, i) = Cell.Offset(0, 2)
                        Tablo(2, i) = Cell.Offset(0, 4)
                        Tablo(3, i) = Cell.Offset(0, 5)
                        Tablo(4, i) = Cell.Offset(0, 7)
                        Tablo(5, i) = Cell.Offset(0, 9)
                End If
                Set Cell = .FindNext(Cell)
            Loop While Not Cell Is Nothing And Cell.Address <> addDeb
Pour réalisé un tri selon plus de deux critères, modifier les paramètres envoyés à la procédure ainsi que la ligne suivante
If Cell.Offset(0, 5) = Critère2 Then
selon ce modèle
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
                If Cell.Offset(0, 5) = Critère2 and _
                    Cell.Offset(0, 7) = Critère3 or _
                    Cell.Offset(0, 6) = Critère4 ...Then
Une explication sur
Me.ListBox1.List = Application.Transpose(Tablo)
ListBoxn.list demande une plage de cellules selon la syntaxe object.List(row, column)
Le problème :
Le tableau utilisé pour renseigner la liste est redimensionnée.
Seule la seconde dimension d'un tableau peut être redimensionné.
Or la première dimension du tableau utilisé correspond au N° de colonne de la liste (fixée au départ) et la seconde dimension "redimensionnée" correspond aux N° de ligne de la liste.
On obtient donc Tablo(column, row) au lieu de Tablo(row, column)
Pour convertir le tableau, il est donc nécessaire d'en inverser les termes. De là l'utilisation de la fonction de la feuille de calculs Transpose.
Application.Transpose(Tablo) "renvoie une plage horizontale de cellules sous forme de plage verticale, ou vice versa" (F1 dans Excel)