[Résolu] Liste déroulante - 3ème niveau défectueux

'Ecriture des choix effectués et des choix à proposer (on selection)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Application.ScreenUpdating = True 'False
    Set f = Sheets("Listing")
    If Not Intersect([B8:B2000], Target) Is Nothing And Target.Count = 1 Then 'Choix1 Type
        f.[u2] = Empty
        f.[A1:A2000].AdvancedFilter Action:=xlFilterCopy, criteriaRange:=f.[u1:u2], CopyToRange:=f.[k1], Unique:=True
    End If
    If Not Intersect([C8:C2000], Target) Is Nothing And Target.Count = 1 Then 'Choix2 Marque
        f.[u2] = Target.Offset(0, -1)
        f.[v2] = Empty
        f.[A1:B2000].AdvancedFilter Action:=xlFilterCopy, criteriaRange:=f.[u1:v2], CopyToRange:=f.[l1], Unique:=True
    End If
    If Not Intersect([D8:D2000], Target) Is Nothing And Target.Count = 1 Then 'Choix3 Dénomination
        f.[u2] = Target.Offset(0, -2)
        f.[v2] = Target.Offset(0, -1)
        f.[w2] = Empty
        f.[A1:C2000].AdvancedFilter Action:=xlFilterCopy, criteriaRange:=f.[u1:w2], CopyToRange:=f.[m1], Unique:=True
    End If
    If Not Intersect([E8:E2000], Target) Is Nothing And Target.Count = 1 Then 'Choix4 Couleur
        f.[u2] = Target.Offset(0, -3)
        f.[v2] = Target.Offset(0, -2)
        f.[w2] = Target.Offset(0, -1)
        f.[x2] = Empty
        f.[A1:D2000].AdvancedFilter Action:=xlFilterCopy, criteriaRange:=f.[u1:x2], CopyToRange:=f.[n1], Unique:=True
    End If
    If Not Intersect([F8:F2000], Target) Is Nothing And Target.Count = 1 Then 'Choix5 Waterproof
        f.[u2] = Target.Offset(0, -4)
        f.[v2] = Target.Offset(0, -3)
        f.[w2] = Target.Offset(0, -2)
        f.[x2] = Target.Offset(0, -1)
        f.[y2] = Empty
        f.[A1:E2000].AdvancedFilter Action:=xlFilterCopy, criteriaRange:=f.[u1:y2], CopyToRange:=f.[o1], Unique:=True
    End If
    If Not Intersect([G8:G2000], Target) Is Nothing And Target.Count = 1 Then 'Choix6 Prix
        f.[u2] = Target.Offset(0, -5)
        f.[v2] = Target.Offset(0, -4)
        f.[w2] = Target.Offset(0, -3)
        f.[x2] = Target.Offset(0, -2)
        f.[y2] = Target.Offset(0, -1)
        f.[z2] = Empty
        f.[A1:F2000].AdvancedFilter Action:=xlFilterCopy, criteriaRange:=f.[u1:z2], CopyToRange:=f.[p1], Unique:=True
    End If
End Sub