XL 2013 Traitement trop long optimisation de code pour générer 2 états

         If Ls > Ls1Acti Then ' La dernière n'est pas la première, donc plusieurs.
            Ls = Ls + 1
            Ts(Ls, 2) = "      Total " & Acti.Id
            Ts(Ls, 5) = "=""R[" & Ls1Acti - Ls & "]C""": End If: Next Acti
      If Ls1Acti > Ls1erBU Then Ls = Ls + 1 ' Début dernier Acti plus loin que début BU…
      If Ls1Acti < Ls Then ' Donc: sauf s'il y en avait une seule dans le BU !
         Ts(Ls, 2) = "Total " & BU.Id
         Ts(Ls, 5) = "=""R[" & Ls1erBU - Ls & "]C""": End If: Next BU

#If False Then '(Partie non compilée ici)
' Le résultat de GroupOrg peut être Affecté à une variable :
      Dim MonGroupeOrganisé As Collection, MaPlage As Range
      Set MonGroupeOrganisé = GroupOrg(MaPlage, 1, 2, -3, , 4, 5)
' Mais on n'en utilisera en général pas, mais plutôt GroupOrg(etc.
' La collection s'explore normalement par :
      Initialisations globales
      For Each SsGrp1 In GroupOrg(MaPlage, etc…)
         Structure interne
         Next SsGrp1
      ConclusionEtTotaux généraux
' SsGrp1 devant être déclaré As SsGroup.
' La structure interne classique pour explorer ce SsGroup est :
      Initialisations , SsGrp1.Id 'est déjà connu à ce niveau.
      For Each Élément In SsGrp1.Contenu
         Structure interne
         Next Élément
      Conclusion Totaux, SsGrp1.Id 'est toujours encore connu.
' S'il concerne la dernière colonne spécifiée (avant vide, nul etc.), Élément doit être un Variant
' et dans la structure interne, Élément(C) représentera une valeur de ligne de détail, colonne C.
' S'il concerne une autre colonne que la dernière spécifiée (avant vide, nul etc.), Élément doit
' être lui même un SsGroup et supportera donc lui aussi cette même structure interne classique.
#End If '(fin des exemples non compilés)

Sub RapportFactu()
Dim ColDate&, Te(), Le&, TLgn&(), Ts(), Ls&, Ls1erPresta&, Ls1BU&, _
PRESTA As SsGroup, _
BU As SsGroup, _
ACTI As SsGroup, _
FACTU As SsGroup, _
Montant As Currency, Détail, C&, Cel As Range

Rem. ——— Chargement des données
With FBase.ListObjects("Base").Range
   ColDate = WorksheetFunction.Match(FBase.[C2].Text, .Rows(1), 0)
   Te = .Rows(2).Resize(.Rows.Count - 1).Value
   End With

Rem. ——— Préfiltrage en vue utilisation fonction GroupOrg
ReDim TLgn(1 To UBound(Te))
For Le = 1 To UBound(Te)
   If Te(Le, ColDate) = "FACTURE" Then
      Ls = Ls + 1: TLgn(Ls) = Le: End If: Next Le
FFactu.Rows(4).Resize(20000).Delete
If Ls = 0 Then
   FFactu.[A3].Value = "IL N'Y A AUCUN ÉLÉMENT À LISTER"
   Exit Sub: End If
ReDim Preserve TLgn(1 To Ls)
MClassement.Préfiltrer TLgn

Rem. ——— Remplissage de l'image de l'état.
ReDim Ts(1 To 50000, 1 To 7): Ls = 0
For Each PRESTA In GroupOrg(Te, 4, 2, 3, 6)
Ls = Ls + 1: Ts(Ls, 1) = PRESTA.Id
Ls1erPresta = Ls + 2

   For Each BU In PRESTA.Contenu
      Ls = Ls + 1: Ts(Ls, 2) = BU.Id
      Ls1BU = Ls + 1
      For Each ACTI In BU.Contenu
               For Each FACTU In ACTI.Contenu
              
         
            Montant = 0
            For Each Détail In FACTU.Contenu
            
               Montant = Montant + Détail(7): Next Détail
            If Montant <> 0 Then
               Ls = Ls + 1
               Ts(Ls, 3) = ACTI.Id
               Ts(Ls, 4) = FACTU.Id
               Ts(Ls, 5) = Montant: End If: Next FACTU, ACTI
               
        
      If Ls > Ls1BU Then ' La dernière n'est pas la première, donc plusieurs.
         Ls = Ls + 1
         Ts(Ls, 2) = "      Total " & BU.Id
         Ts(Ls, 5) = "=""R[" & Ls1BU - Ls & "]C""": End If: Next BU
         
                
   If Ls1BU > Ls1erPresta Then Ls = Ls + 1 ' Début dernier Acti plus loin que début BU…
   If Ls1BU < Ls Then ' Donc: sauf s'il y en avait une seule dans le BU !
      Ts(Ls, 2) = "Total " & PRESTA.Id
     
      
      Ts(Ls, 5) = "=""R[" & Ls1erPresta - Ls & "]C""": End If: Next PRESTA
If Ls > 2 Then
   Ls = Ls + 1: Ts(Ls, 1) = "Total général": Ts(Ls, 5) = "=""R4C"""
ElseIf Ls < 2 Then
   Ts(Ls, 1) = "IL N'Y A AUCUN ÉLÉMENT À LISTER (dans la mesure où ils s'annulent tous)"
   End If
Rem. ——— Production de l'état et ajout de formules.
FFactu.[A3].Resize(Ls, 5).Value = Ts
For Each Cel In FFactu.[E3].Resize(Ls).SpecialCells(xlCellTypeFormulas)
   Cel.FormulaR1C1 = "=SUBTOTAL(9," & Cel.Value & ":R[-1]C)"
   
   Cel.Borders(xlEdgeTop).Weight = xlMedium
Cel.Interior.Color = RGB(146, 208, 80)

                
   Next Cel
End Sub