Microsoft 365 Regroupement de cellule avec somme

Sub TotaliserClients()
    Dim ws As Worksheet
    Dim i As Long
    Dim dict As Object
    Dim Key As Variant
    Dim arr(1) As Double
    
    Set ws = ThisWorkbook.Sheets("Feuil1") 'Changer si besoin
    Set dict = CreateObject("Scripting.Dictionary")
    
    'On démarre à la ligne 2
    For i = 2 To ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
        'Si le code existe dans le dictionnaire, on additionne B et C
        If dict.Exists(ws.Cells(i, "A").Value) Then
            arr(0) = dict(ws.Cells(i, "A").Value)(0) + ws.Cells(i, "B").Value
            arr(1) = dict(ws.Cells(i, "A").Value)(1) + ws.Cells(i, "C").Value
            dict(ws.Cells(i, "A").Value) = arr
        Else
            ' Sinon on ajoute le code au dictionnaire
            arr(0) = ws.Cells(i, "B").Value
            arr(1) = ws.Cells(i, "C").Value
            dict.Add ws.Cells(i, "A").Value, arr
        End If
    Next i
    
    'Effacement plage F2 à H
    ws.Range("F2:H" & ws.Cells(ws.Rows.Count, "F").End(xlUp).Row).ClearContents
    
    'Ecriture totaux
    i = 2
    For Each Key In dict.Keys
        ws.Cells(i, "F").Value = Key
        ws.Cells(i, "G").Value = dict(Key)(0)
        ws.Cells(i, "H").Value = dict(Key)(1)
        i = i + 1
    Next Key
End Sub

Sub Synthese()
    Dim T2 As Range, y As Long, z As Long
    With Worksheets("Feuil1")
        Set Plage = .Range("A1").CurrentRegion
        Plage.Range("A1:C1").Copy Destination:=.Range("E1")
        .ListObjects.Add(xlSrcRange, Plage, , xlYes).Name = "Tableau1"
        y = [Tableau1].ListObject.ListRows.Count
        .Range("E2").Formula2R1C1 = "=UNIQUE(Tableau1[Client])"
        .Range("F2").FormulaR1C1 = "=SUMIFS(Tableau1[CA],Tableau1[Client],RC5)"
        .Range("G2").FormulaR1C1 = "=SUMIFS(Tableau1[CA-N-1],Tableau1[Client],RC5)"
        .Range("F2:G2").AutoFill Destination:=.Range("F2:G" & y)
        .Range("F2:G" & y).Style = "Currency"
        z = .Range("G2").End(xlDown).Row
        Set T2 = .Range("E2:G" & y)
        T2.Copy
        T2.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
        .ListObjects.Add(xlSrcRange, T2.Offset(-1).Resize(z), xlYes).Name = "Synthèse"
        [Synthèse].ListObject.TableStyle = "TableStyleLight9"
        .Columns("A:D").Delete Shift:=xlToLeft
    End With
End Sub