Liste déroulante dynamique

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
Dim Cel As Range, Plg As Range
Dim Fil As Object, Dep As Object, Cat As Object, Ins As Object
Dim FData As Worksheet
Set FData = Sheets("Data")
Set Fil = CreateObject("Scripting.Dictionary"): Set Dep = CreateObject("Scripting.Dictionary")
Set Cat = CreateObject("Scripting.Dictionary"): Set Ins = CreateObject("Scripting.Dictionary")
Set Plg = FData.Range("A2:A" & FData.Cells(Rows.Count, 1).End(xlUp).Row)
Select Case Target.Address
    Case "$A$3"
        Target.Offset(3).ClearContents: Target.Offset(6).Resize(1, 2).ClearContents
        For Each Cel In Plg
            Fil(Cel.Value) = Cel.Value
        Next Cel
        With Target.Validation
            .Delete
            .Add xlValidateList, Formula1:=Join(Fil.Items, ",")
        End With
    Case "$A$6"
        Target.Offset(3).Resize(1, 2).ClearContents
        Target.Validation.Delete
        If Target.Offset(-3) <> "" Then
            For Each Cel In Plg.Offset(, 5)
                If Cel.Offset(, -5) = Target.Offset(-3) Then Dep(Cel.Value) = Cel.Value
            Next Cel
            With Target.Validation
                .Delete
                .Add xlValidateList, Formula1:=Join(Dep.Items, ",")
            End With
        End If
    Case "$A$9"
        Target.Offset(, 1).ClearContents
        Target.Validation.Delete
        If Target.Offset(-6) <> "" And Target.Offset(-3) <> "" Then
            For Each Cel In Plg.Offset(, 1)
                If Cel.Offset(, -1) = Target.Offset(-6) And Cel.Offset(, 4) = Target.Offset(-3) Then Cat(Cel.Value) = Cel.Value
            Next Cel
            With Target.Validation
                .Delete
                .Add xlValidateList, Formula1:=Join(Cat.Items, ",")
            End With
        End If
    Case "$B$9"
        Target.Validation.Delete
        If Target.Offset(-6, -1) <> "" And Target.Offset(-3, -1) <> "" And Target.Offset(, -1) <> "" Then
            For Each Cel In Plg.Offset(, 2)
                If Cel.Offset(, -2) = Target.Offset(-6, -1) And Cel.Offset(, 3) = Target.Offset(-3, -1) And Cel.Offset(, -1) = Target.Offset(, -1) Then Ins(Cel.Value) = Cel.Value
            Next Cel
            With Target.Validation
                .Delete
                .Add xlValidateList, Formula1:=Join(Ins.Items, ",")
            End With
        End If
End Select
End Sub

    For i = 1 To 15
    Case "$A,18+i"
        Target.Offset(, 1).ClearContents
        Target.Validation.Delete
        If Target.Offset(-12 - i, 1) <> "" And Target.Offset(-10 - i, 1) <> "" Then
            For Each Cel In Plg.Offset(, 1)
                If Cel.Offset(, -1) = Target.Offset(-12 - i, 1) And Cel.Offset(, 11) = Target.Offset(-10 - 1, 1) Then Cat(Cel.Value) = Cel.Value
            Next Cel
            With Target.Validation
                .Delete
                .Add xlValidateList, Formula1:=Join(Cat.Items, ",")
            End With
        End If
    Next