Menu déroulant filtrant

Dim zSaisie, NbNiv
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Set zSaisie = Range("B2:G10")
    NbNiv = 4
    If Not Intersect(zSaisie, Target) Is Nothing And Target.Count = 1 Then
      NbLig = [Tableau1].Rows.Count
      Dim TblBD(): ReDim TblBD(1 To NbLig, 1 To 2)
      Dim TblBD2(): ReDim TblBD2(1 To NbLig, 1 To 10)
      For i = 1 To NbLig
        TblBD(i, 1) = [Tableau1].Item(i, 1)
        TblBD(i, 2) = [Tableau1].Item(i, 1).IndentLevel + 1
      Next i
      Dim col(1 To 10)
      nivprec = 10
      For i = 1 To NbLig
        niv = TblBD(i, 2)
        If niv < nivprec Then col(niv) = TblBD(i, 1)
        TblBD2(i, niv) = TblBD(i, 1)
        For k = 1 To niv
          TblBD2(i, k) = col(k)
        Next k
      Next i
      Set d1 = CreateObject("Scripting.Dictionary")
      nivCourant = Target.Column - zSaisie.Column + 1
      Dim Tmp(): ReDim Tmp(1 To nivCourant)
      For k = 1 To nivCourant - 1
        Tmp(k) = Target.Offset(, -(nivCourant - k))
      Next k
      For i = 1 To UBound(TblBD2)
         témoin = True
         For k = 1 To nivCourant - 1
            If TblBD2(i, k) <> Tmp(k) Then témoin = False
         Next k
         If témoin Then d1(TblBD2(i, nivCourant)) = ""
       Next i
       If d1.Count > 0 Then
           temp = Join(d1.keys, ",")
           Target.Validation.Delete
           If temp <> "" Then Target.Validation.Add xlValidateList, Formula1:=temp
        End If
    End If
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  If Not Intersect([A2:A1000], Target) Is Nothing And Target.Count = 1 And Target <> "" Then
    niveau = Target.IndentLevel
    masque = Not Target.Offset(1, 0).EntireRow.Hidden
    i = 1
    Do While Target.Offset(i).IndentLevel > niveau: i = i + 1: Loop
    If i > 1 Then Target.Offset(1).Resize(i - 1).EntireRow.Hidden = masque: Target.Interior.ColorIndex = IIf(masque, 4, 2)
  End If
  Cancel = True
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [B:B]) Is Nothing Then Exit Sub
Dim P As Range, IL%, tout As Boolean
Set P = Intersect(Target(2).Resize(Rows.Count - Target.Row), Target.CurrentRegion)
If P Is Nothing Then Exit Sub
Cancel = True
IL = Target.IndentLevel
If Target.HorizontalAlignment = xlCenter Then tout = True
Target.Interior.ColorIndex = IIf(Target.Interior.ColorIndex = 6, xlNone, 6)
Filtre P, IL, Target.Interior.ColorIndex = 6, tout
End Sub

Sub Filtre(P As Range, IL%, masque As Boolean, tout As Boolean)
Dim i&, plage As Range
For i = 1 To P.Rows.Count
    If Not tout Then If P(i).IndentLevel <= IL Then Exit For
    If P(i).IndentLevel > IL Then Set plage = Union(IIf(plage Is Nothing, P(i), plage), P(i))
Next
If Not plage Is Nothing Then plage.EntireRow.Hidden = masque
End Sub

Sub RAZ()
[B:B].Interior.ColorIndex = xlNone
Rows.Hidden = False
End Sub