Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [D1]) Is Nothing Then Exit Sub
Dim an$, fso As Object, d As Object, sf, fichier$, x$, modele$
an = IIf([D1] = "", "", Replace([D1], "Toutes", "") & "*")
Set fso = CreateObject("Scripting.FileSystemObject")
Set d = CreateObject("Scripting.Dictionary")
On Error Resume Next
For Each sf In fso.getfolder(ThisWorkbook.Path).subfolders
fichier = Dir(sf & "\" & an & "Facture*.xlsx") '1er fichier du dossier
While fichier <> ""
x = "'" & sf & "\[" & fichier & "]Facture de service'!R16C4" 'D16
modele = ""
modele = ExecuteExcel4Macro(x)
If modele <> "" Then d(modele) = d(modele) + 1 'comptabilise
fichier = Dir 'fichier suivant du dossier
Wend
Next
'---restitution---
Range("A2:B" & Rows.Count).Delete xlUp 'RAZ
[A2].Resize(d.Count) = Application.Transpose(d.keys)
[B2].Resize(d.Count) = Application.Transpose(d.items)
[A:B].Sort [A1], xlAscending, Header:=xlYes 'tri alphabétique
End Sub