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