Microsoft 365 TCD multiples colonnes

= Table.ReplaceValue(#"Supprimer le tableau croisé dynamique des autres colonnes",0,null,Replacer.ReplaceValue,{"Valeur"})

= Table.ReplaceValue(#"Supprimer le tableau croisé dynamique des autres colonnes",each[Valeur],each if[Attribut]="DENSITE1" Then (0,null),Replacer.ReplaceValue,{"Valeur"})

Private Sub Worksheet_Activate()
Dim d As Object, ncol%, tablo, resu(), i&, j%, x$, v, nn&, n&
Set d = CreateObject("Scripting.Dictionary")
With Sheets("Feuil1").[A1].CurrentRegion
    ncol = .Columns.Count
    If ncol Mod 2 = 0 Then ncol = ncol + 1 'nombre impair
    tablo = .Resize(, ncol) 'matrice, plus rapide
End With
ReDim resu(1 To UBound(tablo) * ncol, 1 To 2)
For i = 2 To UBound(tablo)
    For j = 2 To ncol Step 2
        x = tablo(i, j)
        If x <> "" Then
            v = tablo(i, j + 1)
            If d.exists(x) Then
                nn = d(x) 'récupère la ligne
                If IsNumeric(CStr(v)) Then resu(nn, 2) = resu(nn, 2) + v
            Else
                n = n + 1
                d(x) = n 'mémorise la ligne
                resu(n, 1) = x
                resu(n, 2) = v
            End If
        End If
Next j, i
'---restitution---
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A2] '1ère cellule de destination
    If n Then
        .Resize(n, 2) = resu
        .Resize(n, 2).Sort .Cells, xlAscending, Header:=xlNo 'tri alphabétique
    End If
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 2).ClearContents 'RAZ en dessous
    .Resize(, 2).EntireColumn.AutoFit 'ajuste les largeurs
End With
End Sub

Private Sub Worksheet_Activate()
Dim d As Object, ncol%, tablo, resu(), i&, an, test$, x$, j%, y$, v, nn&, n&
Set d = CreateObject("Scripting.Dictionary")
With Sheets("Feuil1").[A1].CurrentRegion
    ncol = .Columns.Count
    If ncol Mod 2 = 1 Then ncol = ncol + 1 'nombre pair
    tablo = .Resize(, ncol) 'matrice, plus rapide
End With
ReDim resu(1 To UBound(tablo) * ncol, 1 To 4)
For i = 2 To UBound(tablo)
    an = tablo(i, 1): test = tablo(i, 2)
    x = an & Chr(1) & test & Chr(1)
    For j = 3 To ncol Step 2
        y = tablo(i, j)
        If y <> "" Then
            v = tablo(i, j + 1)
            If d.exists(x & y) Then
                nn = d(x & y) 'récupère la ligne
                If IsNumeric(CStr(v)) Then resu(nn, 4) = resu(nn, 4) + v
            Else
                n = n + 1
                d(x & y) = n 'mémorise la ligne
                resu(n, 1) = an
                resu(n, 2) = test
                resu(n, 3) = y
                resu(n, 4) = v
            End If
        End If
Next j, i
'---restitution---
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A2] '1ère cellule de destination
    If n Then
        .Resize(n, 4) = resu
        .Resize(n, 4).Sort .Cells(1, 3), xlAscending, .Cells, , xlAscending, .Cells(1, 2), xlAscending, Header:=xlNo 'tri sur 3 colonnes
    End If
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 4).ClearContents 'RAZ en dessous
    .Resize(, 4).EntireColumn.AutoFit 'ajuste les largeurs
End With
End Sub