fonction pour filtrage avec des combobox en cascade

**Montor** · 15/09/2008, 19h05

fonction pour filtrage avec des combobox en cascade

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
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
 
Function SetList(this As ComboBox, ParamArray params() As Variant)
Dim sCol As New Collection, stmps As String
Dim j As Long, sRow As Long, b As Long
Dim zt As Integer
Dim tp As Byte, paramid As Byte
Dim Refs As Byte
Dim elem As Variant
Dim setfind As Boolean
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    sRow = Range("A" & Rows.Count).End(xlUp).Row
    Refs = 100
    setfind = True
    paramid = UBound(params)
    ReDim Tableau(Refs)
    For b = 0 To sRow Step Refs
        Tableau = Range("A1:D" & Refs).Offset(b, 0).Value
        For zt = 1 To Refs
            setfind = True
            For tp = 1 To paramid
                If (params(tp) <> Trim(Tableau(zt, tp)) And params(tp) <> "*") Then
                    setfind = False
                    Exit For
                End If
            Next
            If setfind Then
                stmps = Trim(Tableau(zt, paramid + 1))
                If stmps <> "" Then
                    On Error Resume Next
                    sCol.Add stmps, CStr(stmps)
                    Err.Clear
                End If
            End If
        Next
    Next
    If sCol.Count > 0 Then
        ReDim ss(sCol.Count - 1, 0): j = 0
        For Each elem In sCol
            ss(j, 0) = elem
            j = j + 1
        Next
        this.List = ss
    End If
    SetList = sCol.Count
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Function

exemple avec quatre combobox

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
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
 
 
Option Explicit
Function SetList(this As ComboBox, ParamArray params() As Variant)
Dim sCol As New Collection, stmps As String
Dim j As Long, sRow As Long, b As Long
Dim zt As Integer
Dim tp As Byte, paramid As Byte
Dim Refs As Byte
Dim elem As Variant
Dim setfind As Boolean
With Application
        .ScreenUpdating = False
        .EnableEvents = False
End With
sRow = Range("A" & Rows.Count).End(xlUp).Row
Refs = 100
setfind = True
paramid = UBound(params)
ReDim Tableau(Refs)
For b = 0 To sRow Step Refs
Tableau = Range("A1:D" & Refs).Offset(b, 0).Value
For zt = 1 To Refs
setfind = True
For tp = 1 To paramid
If (params(tp) <> Trim(Tableau(zt, tp)) And params(tp) <> "*") Then
setfind = False
Exit For
End If
Next
If setfind Then
stmps = Trim(Tableau(zt, paramid + 1))
If stmps <> "" Then
On Error Resume Next
sCol.Add stmps, CStr(stmps)
Err.Clear
End If
End If
Next
Next
If sCol.Count > 0 Then
ReDim ss(sCol.Count - 1, 0): j = 0
For Each elem In sCol
ss(j, 0) = elem
j = j + 1
Next
this.List = ss
End If
SetList = sCol.Count
With Application
        .ScreenUpdating = True
        .EnableEvents = True
End With
End Function
Private Sub UserForm_Initialize()
If SetList(ComBox1, "") > 1 Then ComBox1.AddItem "*"
End Sub
Private Sub ComBox1_Change()
ComBox2.Clear
If SetList(ComBox2, "", ComBox1.Value) > 1 Then
ComBox2.AddItem "*"
End If
ComBox2_Change
End Sub
Private Sub ComBox2_Change()
ComBox3.Clear
If SetList(ComBox3, "", ComBox1.Value, ComBox2.Value) > 1 Then
ComBox3.AddItem "*"
End If
ComBox3_Change
End Sub
Private Sub ComBox3_Change()
ComBox4.Clear
Call SetList(ComBox4, "", ComBox1.Value, ComBox2.Value, ComBox3.Value)
End Sub

voici le fichier

**Montor** · 16/09/2008, 12h37

Pour eviter chaque fois utilisation de "Combobox.Clear" je les inclus dans la fonction
this.Clear
this.Text = ""

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
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
 
Function SetList(this As ComboBox, _
                            S_Top As Integer, _
                            S_Left As Integer, _
                            S_Fl As Byte, _
                            Feuille As String, _
                            ParamArray params() As Variant)
                            'this       : ComboBox de sortie
                            'S_Top : ligne de debut de plage
                            'S_Left : colonne de debut de plage
                            'S_Fl    : nombre de champs
                            'Feuille : nom de  Feuille
                            'params: reqete
Dim sCol As New Collection, stmps As String
Dim j As Long, sRow As Long
Dim b As Long
Dim tops As Integer, lefts As Integer
Dim zt As Integer
Dim tp As Integer, paramid As Integer
Dim Refs As Byte, p As Byte
Dim elem As Variant
Dim setfind As Boolean
With Worksheets(Feuille)
this.Clear
this.Text = ""
sRow = .Cells(Rows.Count, S_Left).End(xlUp).Row
Refs = 80
setfind = True
tops = S_Top + Refs
lefts = S_Left + (S_Fl - 1)
If IsMissing(params) Then
paramid = -1
Else
paramid = UBound(params)
End If
ReDim Tableau(Refs)
For b = S_Top - 1 To sRow Step Refs
Tableau = .Range(.Cells(S_Top, S_Left), .Cells(tops, lefts)).Offset(b, 0).Value
For zt = 1 To Refs
setfind = True
For tp = 0 To paramid
If (params(tp) <> Tableau(zt, tp + 1) And params(tp) <> "*") Then
setfind = False
Exit For
End If
Next
If setfind Then
stmps = Tableau(zt, paramid + 2)
If stmps <> "" Then
On Error Resume Next
sCol.Add stmps, CStr(stmps)
Err.Clear
End If
End If
Next
Next
End With
If sCol.Count > 0 Then
ReDim ss(sCol.Count - 1, 0)
j = 0
For Each elem In sCol
ss(j, 0) = elem
j = j + 1
Next
this.List = ss
SetList = sCol.Count
Else
SetList = 0
End If
End Function

le meme exemple

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
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
 
Option Explicit
Function SetList(this As ComboBox, _
                            S_Top As Integer, _
                            S_Left As Integer, _
                            S_Fl As Byte, _
                            Feuille As String, _
                            ParamArray params() As Variant)
                            'this       : ComboBox de sortie
                            'S_Top : ligne de debut de plage
                            'S_Left : colonne de debut de plage
                            'S_Fl    : nombre de champs
                            'Feuille : nom de  Feuille
                            'params: reqete
Dim sCol As New Collection, stmps As String
Dim j As Long, sRow As Long
Dim b As Long
Dim tops As Integer, lefts As Integer
Dim zt As Integer
Dim tp As Integer, paramid As Integer
Dim Refs As Byte, p As Byte
Dim elem As Variant
Dim setfind As Boolean
With Worksheets(Feuille)
this.Clear
this.Text = ""
sRow = .Cells(Rows.Count, S_Left).End(xlUp).Row
Refs = 80
setfind = True
tops = S_Top + Refs
lefts = S_Left + (S_Fl - 1)
If IsMissing(params) Then
paramid = -1
Else
paramid = UBound(params)
End If
ReDim Tableau(Refs)
For b = S_Top - 1 To sRow Step Refs
Tableau = .Range(.Cells(S_Top, S_Left), .Cells(tops, lefts)).Offset(b, 0).Value
For zt = 1 To Refs
setfind = True
For tp = 0 To paramid
If (params(tp) <> Tableau(zt, tp + 1) And params(tp) <> "*") Then
setfind = False
Exit For
End If
Next
If setfind Then
stmps = Tableau(zt, paramid + 2)
If stmps <> "" Then
On Error Resume Next
sCol.Add stmps, CStr(stmps)
Err.Clear
End If
End If
Next
Next
End With
If sCol.Count > 0 Then
ReDim ss(sCol.Count - 1, 0)
j = 0
For Each elem In sCol
ss(j, 0) = elem
j = j + 1
Next
this.List = ss
SetList = sCol.Count
Else
SetList = 0
End If
End Function
Private Sub UserForm_Initialize()
If SetList(ComBox1, 1, 1, 4, "Feuil1") > 1 Then ComBox1.AddItem "*"
End Sub
Private Sub ComBox1_Change()
If SetList(ComBox2, 1, 1, 4, "Feuil1", ComBox1.Value) > 1 Then
ComBox2.AddItem "*"
End If
ComBox2_Change
End Sub
Private Sub ComBox2_Change()
If SetList(ComBox3, 1, 1, 4, "Feuil1", ComBox1.Value, ComBox2.Value) > 1 Then
ComBox3.AddItem "*"
End If
ComBox3_Change
End Sub
Private Sub ComBox3_Change()
Call SetList(ComBox4, 1, 1, 4, "Feuil1", ComBox1.Value, ComBox2.Value, ComBox3.Value)
End Sub

**Starsku** · 22/01/2009, 16h56

Bonjour,

Merci pour ton code très pratique.

J'ai essayé de l'adapter à des ListBox en remplaçant simplement Combox par ListBox mais j'ai un message d'erreur.

Y a t-il d'autres changement à faire ? Peux-tu réécrire ton code avec des ListBox ?

Merci d'avance pour ta réponse

**Abed_H** · 09/11/2009, 12h05

voici le fichier

Où se trouve ce fichier ?

fonction pour filtrage avec des combobox en cascade

Contribuez

Discussions similaires

Partager

Partager