Microsoft 365 Création macro Comptabilité double critère synthèse

Option Explicit
Option Compare Text

Sub Consolidation()
   Dim F As Worksheet, col As Integer, derlig As Long, dercol As Integer
   col = Sheets("produit 1").Cells(3, Columns.Count).End(xlToLeft).Column

   With Sheets("synthese")
      .Cells.Clear
      Sheets("produit 1").Range(Sheets("produit 1").Cells(3, 2), Sheets("produit 1").Cells(3, col)).Copy Destination:=.Range("B3")
   End With

   For Each F In ThisWorkbook.Worksheets
      If F.Name <> "SYNTHESe" Then
         With F
            derlig = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
            dercol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
            .Range(.Cells(4, 2), .Cells(derlig, dercol)).Copy _
                  Sheets("synthese").Range("B" & Sheets("synthese").Cells(Rows.Count, 2).End(xlUp).Row + 1)
         End With
      End If
   Next

   With Sheets("synthese")
.activate
      Dim d As Object, TblE, i As Long, lig As Integer, c As Double
      Set d = CreateObject("Scripting.Dictionary")
      TblE = .Range("b3").CurrentRegion
      Dim TblS(): ReDim TblS(1 To UBound(TblE), 1 To UBound(TblE, 2))   ' Table sortie
      For i = LBound(TblE) To UBound(TblE)
         If d.exists(TblE(i, 1)) Then
            lig = d(TblE(i, 1))            ' Récupération index TblS()
         Else
            d(TblE(i, 1)) = d.Count + 1: lig = d.Count: TblS(lig, 1) = TblE(i, 1)
         End If
         For c = 2 To UBound(TblE, 2): TblS(lig, c) = TblS(lig, c) + TblE(i, c): Next c   ' Totalisation numérique
      Next i
      .Range("b3").CurrentRegion.ClearContents
      .[B3].Resize(d.Count, UBound(TblS, 2)) = TblS
   End With
End Sub