Private Sub Worksheet_Activate()
Dim d As Object, w As Worksheet, tablo, i&, x$
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
d("<Tous>") = ""
For Each w In Worksheets
If w.Name <> Me.Name Then
tablo = w.UsedRange.Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
For i = 2 To UBound(tablo)
x = CStr(tablo(i, 1))
If x <> "" Then d(x) = ""
Next i
End If
Next w
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
[Filtre].Validation.Delete 'nom défini
With [Liste] 'nom défini
.Resize(d.Count) = Application.Transpose(d.keys) 'Transpose est limitée à 65536 lignes
If d.Count > 1 Then .Offset(1).Resize(d.Count).Sort .Cells, xlAscending, Header:=xlNo 'tri
[Filtre].Validation.Add xlValidateList, Formula1:="=" & .Resize(d.Count).Address 'liste de validation
.Offset(d.Count).Resize(Rows.Count - d.Count - .Row + 1).ClearContents 'RAZ dessous
Worksheet_Change [Filtre] 'lance la macro
End With
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [Filtre]) Is Nothing Then Exit Sub
Dim crit$, ncol%, w As Worksheet, tablo, i&, x$, n&, a(), j%
crit = LCase(CStr([Filtre]))
ncol = [A1].CurrentRegion.Columns.Count 'cellule à adapter éventuellement
If ncol = 1 Then ncol = 2 'pour avoir au moins 2 éléments
For Each w In Worksheets
If w.Name <> Me.Name Then
tablo = w.UsedRange.Resize(, ncol) 'matrice, plus rapide
For i = 2 To UBound(tablo)
x = CStr(tablo(i, 1))
If x <> "" And (LCase(CStr(tablo(i, 1))) = crit Or crit = "<tous>") Then
n = n + 1
ReDim Preserve a(1 To ncol, 1 To n)
For j = 1 To ncol
a(j, n) = tablo(i, j)
Next j
End If
Next i
End If
Next w
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A2] 'cellule à adapter éventuellement
If n Then
.Resize(n, ncol) = Application.Transpose(a) 'Transpose est limitée à 65536 lignes
.Resize(n, ncol).Borders.Weight = xlThin
.Resize(n, ncol).Sort .Cells(1), xlAscending, Header:=xlNo 'tri pour le cas <Tous>
End If
.Offset(n).Resize(Rows.Count - n - .Row + 1, ncol).Delete xlUp 'RAZ dessous
End With
End Sub
