Private Sub Worksheet_Activate()
Set f = Sheets("BD")
Set Rng = f.Range("A2:E" & f.[A65000].End(xlUp).Row)
TblBD = Rng.Value ' Array pour rapidité
Colcrit1 = 4: Colcrit2 = 1: colOper = 5 ' Colonnes analyse
Set Result = Range("A1") ' Adresse résultat
Set d1 = CreateObject("Scripting.Dictionary") ' Dictionnaire index pour rapidité
Set d2 = CreateObject("Scripting.Dictionary")
Dim TblTot(): ReDim TblTot(1 To UBound(TblBD), 1 To UBound(TblBD, 2))
For i = LBound(TblBD) To UBound(TblBD)
clé1 = TblBD(i, Colcrit1): If d1.exists(clé1) Then lig = d1(clé1) Else d1(clé1) = d1.Count + 1: lig = d1.Count
clé2 = TblBD(i, Colcrit2): If d2.exists(clé2) Then col = d2(clé2) Else d2(clé2) = d2.Count + 1: col = d2.Count
TblTot(lig, col) = TblTot(lig, col) & TblBD(i, colOper) & vbCrLf
Next i
Result.Offset(1).Resize(d1.Count, 1) = Application.Transpose(d1.keys) ' titre lignes
Result.Offset(, 1).Resize(1, d2.Count) = d2.keys ' titres colonnes
Result.Offset(1, 1).Resize(d1.Count, d2.Count) = TblTot ' stat 2D
End Sub