Private Sub Worksheet_Change(ByVal Target As Range)
Dim d As Object, critere As Range, colStatus%, colMotif%, tablo, i, nf$, w As Worksheet, c As Range
If Application.CountIf([Status].EntireColumn, "To be Done") Then
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Set critere = UsedRange(2, UsedRange.Columns.Count + 2)
Application.ScreenUpdating = False
With [Status].CurrentRegion
colStatus = [Status].Column - .Column + 1
colMotif = [Motif].Column - .Column + 1
tablo = .Value 'matrice, plus rapide
Application.EnableEvents = False 'désactive les évènements
On Error Resume Next 'si une feuille n'existe pas
For i = 2 To UBound(tablo)
If LCase(tablo(i, colStatus)) = "to be done" Then
nf = CStr(tablo(i, colMotif))
If Not d.exists(nf) Then
d(nf) = ""
Set w = Nothing
Set w = Sheets(nf)
If w Is Nothing Then
Set w = Sheets.Add(After:=Sheets(Sheets.Count)) 'crée la feuille
w.Name = nf
End If
If w.Cells(1) = "" Then .Rows(1).Copy w.Cells(1) 'ligne d'en-têtes
critere = "=AND(" & [Motif].Offset(1).Address(0) & "=""" & nf & """," & [Status].Offset(1).Address(0) & "=""To be Done"")"
.AdvancedFilter xlFilterInPlace, critere(0).Resize(2) 'filtre avancé
If w.FilterMode Then w.ShowAllData 'si la feuille est filtrée
Set c = w.Cells(w.Rows.Count, 1).End(xlUp)(2)
.SpecialCells(xlCellTypeVisible).Copy c
c.EntireRow.Delete 'supprime la ligne d'en-têtes copiée
w.Columns.AutoFit 'ajustement largeurs
End If
End If
Next
If FilterMode Then ShowAllData 'ôte le filtre avancé
critere = ""
Me.Activate
'---supprime les lignes qui ont été copiées---
[Status].EntireColumn.Insert 'colonne auxiliaire
[Status].Cells(1, 0) = 1
[Status].Cells(1, 0).Resize(.Rows.Count).DataSeries 'numérotation des lignes
.Sort [Status], xlAscending, Header:=xlYes 'tri pour regrouper et accélérer
[Status].EntireColumn.Replace "To be Done", "#N/A"
[Status].EntireColumn.SpecialCells(xlCellTypeConstants, 16).EntireRow.Delete
.Sort [Status].Cells(1, 0), xlAscending 'ordre initial
[Status].Cells(1, 0).EntireColumn.Delete 'supprime la colonne auxiliaire
Application.EnableEvents = True 'réactive les évènements
End With
With UsedRange: End With 'actualise les barres de défilement
End If
End Sub