XL pour MAC Créer un sous groupe à partir d'un groupe

Private Sub Worksheet_Activate()
Dim tablo, d As Object, col%, c As Range, x$, n&, resu(), i&, y$, nn&, v, hauteur&
With Sheets("Journal")
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    tablo = .Range("B7:I" & .Cells(Rows.Count, 2).End(xlUp).Row) 'matrice, plus rapide
End With
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'évite le recalcul des formules volatiles
With [Tableau1] 'tableau structuré
    .ListObject.ShowTotals = False 'masque la ligne Total
    For col = 1 To .Columns.Count Step 2
        Set c = .Cells(0, col) 'ligne des en-têtes
        x = LCase(Trim(c))
        n = 0
        ReDim resu(1 To UBound(tablo), 1 To 2) 'réinitialise le tableau des résultats
        For i = 1 To UBound(tablo)
            If LCase(Trim(tablo(i, 2))) = x Then
                y = Trim(tablo(i, 3))
                If Not d.exists(y) Then
                    n = n + 1
                    d(y) = n 'mémorise la ligne
                    resu(n, 1) = y
                End If
                nn = d(y)
                v = tablo(i, 8)
                If IsNumeric(v) Then resu(nn, 2) = resu(nn, 2) + CDbl(v)
            End If
        Next i
        If n Then c(2).Resize(n, 2) = resu 'restitution
        If n > hauteur Then hauteur = n
    Next col
    If .Rows.Count > hauteur Then .Rows(hauteur + 1).Resize(.Rows.Count - hauteur).Delete xlUp 'RAZ en dessous
    .ListObject.ShowTotals = True 'affiche la ligne Total
    .EntireColumn.AutoFit 'ajustement largeurs
End With
Application.Calculation = xlCalculationAutomatic
End Sub

Option Compare Text 'la casse est ignorée

Private Sub Worksheet_Activate()
Dim tablo, col%, c As Range, x$, n&, resu(), i&, y$, coll As New Collection, v, hauteur&
With Sheets("Journal")
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    tablo = .Range("B7:I" & .Cells(Rows.Count, 2).End(xlUp).Row) 'matrice, plus rapide
End With
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'évite le recalcul des formules volatiles
With [Tableau1] 'tableau structuré
    .ListObject.ShowTotals = False 'masque la ligne Total
    For col = 1 To .Columns.Count Step 2
        Set c = .Cells(0, col) 'ligne des en-têtes
        x = LCase(Trim(c))
        n = 0
        ReDim resu(1 To UBound(tablo), 1 To 2) 'réinitialise le tableau des résultats
        For i = 1 To UBound(tablo)
            If LCase(Trim(tablo(i, 2))) = x Then
                y = Trim(tablo(i, 3))
                n = n + 1
                On Error Resume Next
                coll.Add n, y
                If Err Then n = n - 1 Else resu(n, 1) = y
                v = tablo(i, 8)
                If IsNumeric(v) Then resu(coll(y), 2) = resu(coll(y), 2) + CDbl(v)
            End If
        Next i
        If n Then c(2).Resize(n, 2) = resu 'restitution
        If n > hauteur Then hauteur = n
    Next col
    If .Rows.Count > hauteur Then .Rows(hauteur + 1).Resize(.Rows.Count - hauteur).Delete xlUp 'RAZ en dessous
    .ListObject.ShowTotals = True 'affiche la ligne Total
    .EntireColumn.AutoFit 'ajustement largeurs
End With
Application.Calculation = xlCalculationAutomatic
End Sub