Option Explicit
Sub Synthèse()
Dim LOtSy As ListObject, RngSy As Range, LMax As Long, _
WshAg As Worksheet, LOtAg As ListObject, RngAg As Range
Set LOtSy = WshSynth.ListObjects(1)
Set RngSy = LOtSy.HeaderRowRange.Offset(1)
Set WshAg = WshAg1
Do: Set LOtAg = WshAg.ListObjects(1)
If LOtAg.ListRows.Count = 0 Then
Set RngAg = LOtAg.HeaderRowRange.Offset(1)
Else: Set RngAg = LOtAg.DataBodyRange: End If
RngSy.Rows(LMax + 1).Resize(RngAg.Rows.Count).Value = RngAg.Value
RngSy(LMax + 1, 1).Resize(RngAg.Rows.Count).Value = UCase(WshAg.Name)
LMax = LMax + RngAg.Rows.Count
Set WshAg = WshAg.Next: Loop Until WshAg Is Nothing
SupprimerReste LOtAg, LMax
End Sub
Sub ÉclaterParAgences()
Dim TSy(), WshAg As Worksheet, Sujet, TNomAg(), TTLSy(), N As Long, _
TLSy() As Long, LSy As Long, LAg As Long, C As Long, LOtAg As ListObject
TSy = WshSynth.ListObjects(1).DataBodyRange.Value
Set WshAg = WshAg1
Do: WshAg.Name = WshAg.CodeName: Set WshAg = WshAg.Next: Loop Until WshAg Is Nothing
Sujet = CBxL.SujetCBx(TSy): TNomAg = Sujet(0): TTLSy = Sujet(1)
Set WshAg = WshAg1
For N = 0 To UBound(TNomAg)
If N > 0 Then Set WshAg = WshAg.Next: If WshAg Is Nothing Then _
WshAg.Copy After:=WshAg: Set WshAg = WshAg.Next
WshAg.Name = TNomAg(N): TLSy = TTLSy(N)
ReDim TAg(1 To UBound(TLSy), 1 To 12)
For LAg = 1 To UBound(TLSy)
LSy = TLSy(LAg): For C = 1 To 12: TAg(LAg, C) = TSy(LSy, C): Next C, LAg
Set LOtAg = WshAg.ListObjects(1)
LOtAg.HeaderRowRange.Offset(1).Value = TAg
SupprimerReste LOtAg, UBound(TAg, 1)
Next N
End Sub
Private Sub SupprimerReste(ByVal LOt As ListObject, ByVal LMax As Long)
If LOt.ListRows.Count > LMax Then LOt.ListRows(LMax + 1).Range _
.Resize(LOt.ListRows.Count - LMax).Delete xlShiftUp
End Sub