Private Sub Worksheet_Change(ByVal Target As Range)
Dim dat1, dat2, exclu, colonne, i&, BD As Worksheet, critere As Range, d As Object, tablo, dat, x$, col
dat1 = [D4]: dat2 = [D5]
If Not IsDate(dat1) Or Not IsDate(dat2) Then Exit Sub
exclu = Array("Accueil", "BD") 'feuilles à exclure, à adapter
colonne = Array(8, 9, 10, 11, 12, 13, 14, 16, 17, 19) 'numéros des colonnes, à adapter
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = Worksheets.Count To 1 Step -1
If IsError(Application.Match(Worksheets(i).Name, exclu, 0)) Then Worksheets(i).Delete
Next
Set BD = Sheets("BD")
Set critere = BD.UsedRange(2, BD.UsedRange.Columns.Count + 2)
tablo = BD.[A1].CurrentRegion.Resize(, 24) 'matrice, plus rapide
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 2 To UBound(tablo)
dat = tablo(i, 2)
If IsDate(dat) Then
If CDate(dat) >= dat1 And CDate(dat) <= dat2 Then
x = CStr(tablo(i, 24))
If Not d.exists(x) Then
Set d(x) = Sheets.Add(After:=Sheets(Sheets.Count))
d(x).Name = x
critere = "=AND(--B2>=" & CLng(dat1) & ",--B2<=" & CLng(dat2) & ",X2=""" & x & """)"
With BD.Cells(1).CurrentRegion
.AdvancedFilter xlFilterInPlace, critere(0).Resize(2) 'filtre avancé
.SpecialCells(xlCellTypeVisible).Copy d(x).Cells(1) 'copier-coller
End With
With d(x).Cells(Rows.Count, 1).End(xlUp)(2)
For Each col In colonne
.Cells(0, col).AutoFill .Cells(0, col).Resize(2), xlFillFormats
.Cells(1, col) = "=SUM(R1C:R[-1]C)"
Next col
.EntireRow.Font.Bold = True 'gras
.EntireRow.Font.ColorIndex = 3 'police rouge
End With
End If
End If
End If
Next i
critere = ""
Application.Goto Target
End Sub