Private Sub Worksheet_Change(ByVal Target As Range)
Dim tablo, d As Object, dd As Object, i&, x$, n&, a, resu(), nn&
tablo = [Tableau2] 'tableau structuré
Set d = CreateObject("Scripting.Dictionary")
Set dd = CreateObject("Scripting.Dictionary")
'---liste des régions---
For i = 1 To UBound(tablo)
x = tablo(i, 1)
If Not d.exists(x) Then
d(x) = n 'mémorise la position de la ligne
n = n + 1
End If
Next i
'---tableau des résultats---
If n Then 'si le tableau n'est pas vide
a = d.keys
ReDim resu(UBound(a), 2) 'base 0
For i = 0 To UBound(a)
resu(i, 0) = a(i) '1ère colonne
Next i
For i = 1 To UBound(tablo)
If tablo(i, 5) = "Sortie" Then
x = tablo(i, 1) & Chr(1) & tablo(i, 2)
If Not dd.exists(x) Then
dd(x) = ""
nn = d(tablo(i, 1)) 'récupère la position de la ligne
resu(nn, 1) = resu(nn, 1) + 1 'comptage en 2ème colonne
End If
End If
Next i
dd.RemoveAll 'RAZ
For i = 1 To UBound(tablo)
If tablo(i, 5) = "Sortie" Then
x = tablo(i, 1) & Chr(1) & tablo(i, 3)
If Not dd.exists(x) Then
dd(x) = ""
nn = d(tablo(i, 1)) 'récupère la position de la ligne
resu(nn, 2) = resu(nn, 2) + 1 'comptage en 3ème colonne
End If
End If
Next i
End If
'---restitution---
Application.EnableEvents = False 'désactive les évènements
With [I3] '1ère cellule de destination, à adapter
If n Then .Resize(n, 3) = resu
.Offset(n).Resize(Rows.Count - n - .Row + 1, 3).ClearContents 'RAZ en dessous
End With
Application.EnableEvents = True 'réactive les évènements
End Sub