Filtres élaborés

Bonjour

Prière de nous aider pour compléter cet userform

merci d'avance

Bonjour,

Prière de ne pas rédiger un texto et de donner des explications

De rien

Bonjour

Les données sont en deux feuilles : "payant" et "gratuit"

Troisième feuille "temp" est lié au userform

payant

gratuit

userform

Explication

codes usf

Private Sub CheckBox1_Click()

End Sub

Private Sub ComboBox1_Change()
    If Me.ComboBox1.Value = "GRATUIT" Then
        Me.ComboBox2.Visible = True
    Else
        Me.ComboBox2.Visible = False
    End If
End Sub

Private Sub ComboBox2_Change()
    If Me.ComboBox2 = "" Then
            temp.Range("S2").Value = ""
    Else
            temp.Range("S2").Value = ComboBox2.Text
    End If

End Sub

Private Sub ComboBox3_Change()
    If Me.ComboBox3 = "" Or Me.ComboBox3 = "TOUT" Then
            temp.Range("E2").Value = ""
'            temp.Range("O2").Value = ""
    Else
            temp.Range("E2").Value = ComboBox3.Text
'            temp.Range("O2").Value = ComboBox3.Text
    End If

End Sub

Private Sub ComboBox4_Change()
    If Me.ComboBox4 = "" Or Me.ComboBox4 = "TOUT" Then
            temp.Range("F2").Value = ""
'            temp.Range("P2").Value = ""
    Else
            temp.Range("F2").Value = ComboBox4.Text
'            temp.Range("P2").Value = ComboBox4.Text
    End If

End Sub

Private Sub CommandButton1_Click()
Dim LISTArray()
Dim I As Byte
Dim E As Long: E = 0
Dim RW As Long
         temp.Range("A4:H500000").Delete Shift:=xlUp
         temp.Range("K4:R500000").Delete Shift:=xlUp
         Me.ListBox1.Clear

    Select Case Me.ComboBox1.Text
        Case "TOUT"
            Call PAYANT
            Call GRATUIT
            LRWPAYANT = temp.Range("a100000").End(xlUp).Row
            LRWGRATUIT = temp.Range("k100000").End(xlUp).Row

                If LRWPAYANT = 3 Then GoTo 1
                For RW = 4 To LRWPAYANT
                E = E + 1: ReDim Preserve LISTArray(1 To 8, 1 To E)
                           For I = 1 To 8
                                LISTArray(I, E) = temp.Cells(RW, I)
                           Next
                Next
                If LRWGRATUIT = 3 Then GoTo 2
1               For RW = 4 To LRWGRATUIT
                E = E + 1: ReDim Preserve LISTArray(1 To 8, 1 To E)
                           For I = 1 To 8
                                LISTArray(I, E) = temp.Cells(RW, I + 10)
                           Next
                Next
2               If E > 0 Then
                    If UBound(LISTArray, 2) > 1 Then
                        Me.ListBox1.List = Application.Transpose(LISTArray)
                        Else
                        Dim c(1 To 1, 1 To 8)
                            For I = 1 To 8
                                 c(1, I) = LISTArray(I, 1)
                            Next
                        Me.ListBox1.List = c
                    End If
                End If
        Case "PAYANT"
            Call PAYANT
            LRWPAYANT = temp.Range("a100000").End(xlUp).Row
            Me.ListBox1.List = temp.Range("a4:h" & LRWPAYANT).Value
        Case "GRATUIT"
            Call GRATUIT
            LRWGRATUIT = temp.Range("k100000").End(xlUp).Row
            Me.ListBox1.List = temp.Range("k4:r" & LRWGRATUIT).Value
    End Select
TextBox3.Value = Me.ListBox1.ListCount
TextBox4.Value = temp.Range("x1").Value
End Sub

Private Sub CommandButton2_Click()
Effacer
End Sub

Private Sub DTPicker1_Change()

    If Me.ComboBox1.Text = "" Or Me.ComboBox1.Text = "TOUT" Then
        temp.Range("T1").Value = DTPicker1.Value
        temp.Range("T2").Value = DTPicker1.Value
    ElseIf Me.ComboBox1.Text = "PAYANT" Then
        temp.Range("T1").Value = DTPicker1.Value
    ElseIf Me.ComboBox1.Text = "GRATUIT" Then
        temp.Range("T2").Value = DTPicker1.Value
    End If

End Sub

Private Sub DTPicker2_Change()

    If Me.ComboBox1.Text = "" Or Me.ComboBox1.Text = "TOUT" Then
        temp.Range("U1").Value = DTPicker2.Value
        temp.Range("U2").Value = DTPicker2.Value
    ElseIf Me.ComboBox1.Text = "PAYANT" Then
        temp.Range("U1").Value = DTPicker2.Value
    ElseIf Me.ComboBox1.Text = "GRATUIT" Then
        temp.Range("U2").Value = DTPicker2.Value
    End If
End Sub

Private Sub Frame2_Click()

End Sub

Private Sub UserForm_Activate()
    With Me
        With .ComboBox1
            .AddItem "TOUT"
            .AddItem "PAYANT"
            .AddItem "GRATUIT"
        End With
        With .ComboBox2
            .AddItem "CARTE"
            .AddItem "RECU"
            .AddItem "CERTIFICAT"
        End With
        With .ComboBox3
            .AddItem "TOUT"
            .AddItem "CSORL"
            .AddItem "CGORL"
            .AddItem "CML"
            .AddItem "URGENCES"
            .AddItem "AMY"
            .AddItem "AMY2"
            .AddItem "APCH"
            .AddItem "CSTOMA"
            .AddItem "HJSTOM"
        End With
        With .ComboBox4
            .AddItem "TOUT"
            .AddItem "CSS"
            .AddItem "CSORL"
            .AddItem "CGORL"
            .AddItem "D296"
            .AddItem "D254"
            .AddItem "D331"
            .AddItem "CTRAMY"
            .AddItem "D352"
            .AddItem "BAMY"
            .AddItem "CSTOMA"
            .AddItem "D744"
            .AddItem "D736"
            .AddItem "ORL"
            .AddItem "OPH"
        End With
    End With
End Sub

Private Sub UserForm_Click()

End Sub

codes module

Sub PAYANT()

    Application.CutCopyMode = False
    Sheets("payant").Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=temp.Range("A1:I2"), CopyToRange:=temp.Range("A3:H3"), Unique:=False
End Sub
Sub GRATUIT()

    Application.CutCopyMode = False
    Sheets("Gratuit").Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=temp.Range("K1:S2"), CopyToRange:=temp.Range("K3:R3"), Unique:=False
End Sub
Sub Effacer()
    With temp
        .Range("C2:I2").ClearContents
        .Range("t1:u1").ClearContents
        .Range("M2:U2").ClearContents
        .Range("A4:H500000").Delete Shift:=xlUp
        .Range("K4:R500000").Delete Shift:=xlUp
    End With
End Sub

Sub shUF()
    UserForm1.Show
End Sub

Exemple de résultats