Option Explicit
'
Private Sub Worksheet_Activate()
Rapport
End Sub
'
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Me.[B1], Target) Is Nothing Then Rapport
End Sub
'
Private Sub Rapport()
Dim Te(), Le&, Ti(), Li&, Ts(), Ls&, C&, DTit As Dictionary, SGDate As SsGroup, TLgn() As Long, _
LaDate As Date, SGLieu As SsGroup, SGNomT As SsGroup, Cumul As Double, Détail, Cel As Range
Rem. ——— Acquisition, empilement dans un tableau intermédiaire unique.
Te = Utilit.PlgUti(FExport.[A2]).Value
ReDim Ti(1 To UBound(Te, 1) * (UBound(Te, 2) - 2) \ 2, 1 To 4)
For Le = 1 To UBound(Te, 1)
For C = 4 To UBound(Te, 2) Step 2
If Not IsEmpty(Te(Le, C)) Then
Li = Li + 1
Ti(Li, 1) = Te(Le, 1)
Ti(Li, 2) = Te(Le, 2)
Ti(Li, 3) = Te(Le, C - 1)
Ti(Li, 4) = Te(Le, C): End If: Next C, Le
' On a 1:Date, 2:Lieu, 3:NomT, 4:Nbre
Rem. ——— Constitution d'une table de numéros des lignes à considérer.
LaDate = Me.[B1].Value
ReDim TLgn(1 To Li)
For Le = 1 To Li
If Ti(Le, 1) = LaDate Then Ls = Ls + 1: TLgn(Ls) = Le
Next Le
If Ls = 0 Then
ReDim Ts(1 To 2, 1 To 3): Ts(1, 1) = LaDate: Ts(2, 1) = "Aucun élément."
Application.EnableEvents = False: ValPlgAju(Me.[Rapport]) = Ts
Application.EnableEvents = True: Exit Sub: End If
ReDim Preserve TLgn(1 To Ls)
Rem. ——— Inventaire des lieux
MClassement.Préfiltrer TLgn
Set DTit = MClassement.DicInvent(Ti, 2, 2)
Rem. ——— Construction tableau image du rapport.
ReDim Ts(1 To 50000, 1 To DTit.Count + 2)
Ts(1, 1) = LaDate
Te = DTit.Keys: For C = 2 To UBound(Ts, 2) - 1: Ts(1, C) = Te(C - 2): Next C
Ts(1, DTit.Count + 2) = "Total"
Ls = 1
MClassement.Préfiltrer TLgn
For Each SGNomT In GroupOrg(Ti, 3, 2)
Ls = Ls + 1
Ts(Ls, 1) = SGNomT.Id
For Each SGLieu In SGNomT.Contenu
Cumul = 0
For Each Détail In SGLieu.Contenu
Cumul = Cumul + Détail(4)
Next Détail
Ts(Ls, DTit(SGLieu.Id)) = Cumul
Next SGLieu, SGNomT
Rem. ——— Production du rapport et ajout de formules totaux.
Application.EnableEvents = False
Utilit.ValPlgAju(Me.[Rapport], Ls) = Ts
With Me.[Rapport]: .Cells(2, .Columns.Count).Resize(.Rows.Count - 1) _
.FormulaR1C1 = "=SUM(OFFSET(RC" & .Column & ",0,1):OFFSET(RC,0,-1))": End With
Application.EnableEvents = True
End Sub