Dim P As Range 'mémorise la variable
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range
Set P = [F7:H20] 'à adapter
Set r = Intersect(Target, P.Resize(, 2))
If r Is Nothing Then Exit Sub
Application.EnableEvents = False 'désactive les évènements
For Each r In r
r(1, 2).Resize(, IIf(r.Column = P.Columns(1).Column, 2, 1)) = ""
Next
Application.EnableEvents = True 'réactive les évènements
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Set P = [F7:H20] 'à adapter
P.Validation.Delete 'RAZ
If Intersect(ActiveCell, P) Is Nothing Then Exit Sub
Set P = Intersect(ActiveCell.EntireRow, P)
If ActiveCell.Column = P(1).Column Then
Liste 1
ElseIf ActiveCell.Column = P(2).Column Then
If P(1) = "" Then P(1).Select Else Liste 2
ElseIf ActiveCell.Column = P(3).Column Then
If P(2) = "" Then P(2).Select Else Liste 3
End If
End Sub
Sub Liste(col%)
Dim d As Object, tablo, x$, y$, i&
Set d = CreateObject("Scripting.Dictionary")
tablo = [Tableau1] 'matrice, plus rapide
x = P(1): y = P(2)
For i = 1 To UBound(tablo)
If IIf(col > 1, tablo(i, 1) = x And IIf(col = 3, tablo(i, 2) = y, True), True) Then d(tablo(i, col)) = ""
Next
With Sheets("Liste")
.Columns(1).ClearContents
If d.Count Then
.[A1].Resize(d.Count) = Application.Transpose(d.keys) 'Transpose est limitée à 65536 lignes
P(col).Validation.Add xlValidateList, Formula1:="=" & .[A1].CurrentRegion.Address(External:=True)
End If
End With
End Sub