Sub test()
Dim a, e, s, i As Long, n As Long, dic(1) As Object
Set dic(0) = CreateObject("Scripting.Dictionary")
Set dic(1) = CreateObject("Scripting.Dictionary")
a = Sheets("BD").[a1].CurrentRegion.Value
For i = 2 To UBound(a, 1)
If Year(a(i, 1)) < 2024 Then
If Not dic(1).exists(a(i, 4)) Then dic(1)(a(i, 4)) = dic(1).Count + 2
If Not dic(0).exists(a(i, 6)) Then
Set dic(0)(a(i, 6)) = CreateObject("Scripting.Dictionary")
End If
dic(0)(a(i, 6))(a(i, 4)) = dic(0)(a(i, 6))(a(i, 4)) + 1
End If
Next
For i = 2 To UBound(a, 1)
If Year(a(i, 1)) < 2024 Then
If Not dic(1).exists(a(i, 13)) Then dic(1)(a(i, 13)) = dic(1).Count + 2
If a(i, 4) = "Fa" Then
dic(0)(a(i, 6))(a(i, 13)) = dic(0)(a(i, 6))(a(i, 13)) + 1
End If
End If
Next
If Not dic(1).exists("DateDC") Then dic(1)("DateDC") = dic(1).Count + 2
For i = 2 To UBound(a, 1)
If Year(a(i, 1)) < 2024 Then
If Not IsEmpty(a(i, 14)) Then
If Year(a(i, 14)) = Year(a(i, 1)) Then
dic(0)(a(i, 6))("DateDC") = dic(0)(a(i, 6))("DateDC") + 1
End If
End If
End If
Next
ReDim a(1 To dic(0).Count + 1, 1 To dic(1).Count + 1)
For Each e In dic(0)
n = n + 1: a(n, 1) = e
For Each s In dic(0)(e)
a(n, dic(1)(s)) = dic(0)(e)(s)
Next
Next
With Sheets("Feuil3").[a1]
.Value = "Espèce"
.Range("b1").Resize(, dic(1).Count) = dic(1).keys
.Range("a2").Resize(dic(0).Count, dic(1).Count + 1) = a
End With
End Sub