Microsoft 365 Compter des quantités sur plusieurs critères

Sub Unique()
Dim F As Worksheet, d As Object, i&, x$
Set F = Sheets("Unique") 'à adapter
Set d = CreateObject("Scripting.Dictionary")
With [A1].CurrentRegion.Resize(, 30)
ReDim resu(1 To .Rows.Count, 1 To 1)
resu(1, 1) = "Quantité"
    For i = 2 To .Rows.Count
        x = .Cells(i, 6) & .Cells(i, 16) & .Cells(i, 18)
        If x <> "" And Not d.exists(x) Then d(x) = i
        resu(d(x), 1) = resu(d(x), 1) + 1
    Next
    .AutoFilter
    .Columns(30) = resu
    .AutoFilter 30, ">0"
    F.Cells.Delete 'RAZ
    .Copy F.[A1] 'copier-coller
    F.Columns.AutoFit 'ajustement largeurs
    .Columns(30) = ""
    .AutoFilter 'ôte le filtre
    Application.Goto F.[A1], True 'cadrage
End With
End Sub

Private Sub Worksheet_Activate()
Dim d As Object, i&, x$
Set d = CreateObject("Scripting.Dictionary")
With Sheets("Feuil1").[A1].CurrentRegion.Resize(, 30)
ReDim resu(1 To .Rows.Count, 1 To 1)
resu(1, 1) = "Quantité"
    For i = 2 To .Rows.Count
        x = .Cells(i, 6) & .Cells(i, 16) & .Cells(i, 18)
        If x <> "" And Not d.exists(x) Then d(x) = i
        resu(d(x), 1) = resu(d(x), 1) + 1
    Next
    Application.ScreenUpdating = False
    .AutoFilter
    .Columns(30) = resu
    .AutoFilter 30, ">0"
    Cells.Delete 'RAZ
    .Copy [A1] 'copier-coller
    Columns.AutoFit 'ajustement largeurs
    .Columns(30) = ""
    .AutoFilter 'ôte le filtre
    Application.Goto [A1], True 'cadrage
End With
End Sub

Private Sub Worksheet_Activate()
' 2 paramètres : nom de la feuille source - liste des 3 colonnes (lettres)
Const FeuilSource = "Feuil1", colonnes = "A F H"
Dim cols, wksSource As Worksheet, der&, x, i&, t, i0&, n&
   Application.ScreenUpdating = False: cols = Split(colonnes): Set wksSource = Sheets(FeuilSource)
   With Me
      .Columns("a:d").Clear
      For Each x In Split(colonnes): i = i + 1: wksSource.Range(x & 1).EntireColumn.Copy .Columns(i): Next
      der = .Cells(Rows.Count, 1).End(xlUp).Row
      With .Range("a1").Resize(der, 4)
         .Sort key1:=[a1], order1:=1, key2:=[b1], order2:=1, key3:=[c1], order3:=1, Header:=1, MatchCase:=False
         t = .Value
      End With
      t(1, 4) = "Qté": i0 = 2: n = 1
      For i = 2 To UBound(t)
         If t(i, 1) <> t(i0, 1) Or t(i, 2) <> t(i0, 2) Or t(i, 3) <> t(i0, 3) Then
            n = n + 1: t(n, 4) = i - i0
            t(n, 1) = t(i0, 1): t(n, 2) = t(i0, 2): t(n, 3) = t(i0, 3)
            i0 = i
         End If
      Next i
      If t(i0, 1) & t(i0, 2) & t(i0, 3) <> "" Then
         n = n + 1: t(n, 4) = i - i0
         t(n, 1) = t(i0, 1): t(n, 2) = t(i0, 2): t(n, 3) = t(i0, 3)
      End If
      .Columns("a:d").Clear
      With .Range("a1").Resize(n, 4)
         .Value = t: .Borders.LineStyle = xlContinuous: .Columns.AutoFit
         .Rows(1).Font.Bold = True: .Rows(1).Interior.Color = RGB(220, 250, 220)
      End With
   End With
End Sub

Private Sub Worksheet_Activate()
Dim d As Object, tablo, resu(), i&, x$, n&, j%, nn&
Set d = CreateObject("Scripting.Dictionary")
tablo = Sheets("Feuil1").[A1].CurrentRegion.Resize(, 29) 'matrice, plus rapide
ReDim resu(1 To UBound(tablo), 1 To 30)
For i = 1 To UBound(tablo)
    x = tablo(i, 6) & tablo(i, 16) & tablo(i, 18)
    If x <> "" Then
        If Not d.exists(x) Then
            n = n + 1
            d(x) = n
            For j = 1 To 29: resu(n, j) = tablo(i, j): Next j
        End If
        nn = d(x)
        resu(nn, 30) = resu(nn, 30) + 1
    End If
Next i
resu(1, 30) = "Quantité"
'---restitution---
Application.ScreenUpdating = False
Cells.Delete 'RAZ
If n = 0 Then Exit Sub
[A1].Resize(n, 30) = resu
Rows(1).Font.Bold = True
Columns(30).HorizontalAlignment = xlCenter
Columns.AutoFit 'ajustement largeurs
End Sub

let
    Source = Excel.CurrentWorkbook(){[Name="T_Data"]}[Content],
    GroupBy = Table.Group(Source, T_Crit[Titre], {{"Nombre", each Table.RowCount(_), Int64.Type}})
in
    GroupBy

let
    Source = Excel.CurrentWorkbook(){[Name="T_Data"]}[Content],
    GroupBy = Table.Group(Source, T_Crit[Titre], {{"Nombre", each Table.RowCount(_), Int64.Type},{"Longueur totale", each List.Sum([LONGUEUR]), type number}})
in
    GroupBy

Private Sub Worksheet_Activate()
Dim d As Object, tablo, resu(), i&, x$, nn&, v, n&, j%
Set d = CreateObject("Scripting.Dictionary")
tablo = Sheets("Feuil1").[A1].CurrentRegion.Resize(, 29) 'matrice, plus rapide
ReDim resu(1 To UBound(tablo), 1 To 30)
For i = 1 To UBound(tablo)
    x = tablo(i, 6) & tablo(i, 16) & tablo(i, 18)
    If x <> "" Then
        If d.exists(x) Then
            nn = d(x)
            v = tablo(i, 26) 'en colonne Z
            If IsNumeric(CStr(v)) Then resu(nn, 26) = resu(nn, 26) + v 'Longueur totale
            resu(nn, 30) = resu(nn, 30) + 1 'Quantité
        Else
            n = n + 1
            d(x) = n
            For j = 1 To 29: resu(n, j) = tablo(i, j): Next j
            If i > 1 And Not IsNumeric(resu(n, 26)) Then resu(n, 26) = Empty 'colonne Z
            resu(n, 30) = 1
        End If
    End If
Next i
resu(1, 30) = "Quantité"
'---restitution---
Application.ScreenUpdating = False
Cells.Delete 'RAZ
If n = 0 Then Exit Sub
[A1].Resize(n, 30) = resu
Rows(1).Font.Bold = True
Columns(30).HorizontalAlignment = xlCenter
Columns.AutoFit 'ajustement largeurs
End Sub