Option Explicit
Private Sub Worksheet_Activate()
Dim LOtDoc As ListObject, C As Long, L As Long, RngRenv As Range, TSrc(), CelTit As Range, RngDonn As Range, Wsh As Worksheet, _
TSyn(), Code As SsGr, Détail, Dsgn As String, LDéb As Long, CEstLeDébut As Boolean, IlFautAvancer As Boolean, CEstUneSuite3ou4 As Boolean
Rem. — Analyse de la documentation.
Set LOtDoc = WshDoc.ListObjects("TabDoc")
For C = 2 To 5 ' Colonnes des sources.
Set RngRenv = LOtDoc.ListColumns(C).DataBodyRange ' Récupère la colonne des renvois aux titres.
For L = 1 To RngRenv.Rows.Count
If RngRenv.Rows(L).HasFormula Then ' Pour chaque cellule portant une formule :
Set CelTit = Evaluate(RngRenv.Rows(L).Formula)
If RngDonn Is Nothing Then ' Initialisations plage et tableaux impliqués.
Set Wsh = CelTit.Worksheet
Set RngDonn = Intersect(Wsh.Rows(CelTit.Row + 1).Resize(1000000 - CelTit.Row), Wsh.UsedRange)
TSrc = RngDonn.Value
ReDim TCbl(1 To UBound(TSrc), 1 To 14)
End If
GarnirColonne TCbl, L, TSrc, CelTit.Column ' Transfère les valeurs de la colonne.
End If
Next L
AjouterTableau TCbl ' La fonction TableUniqueCréée renvera dans un seul les tableaux ainsi mis bout à bout.
Set RngDonn = Nothing
Next C
Rem. — Préparation du résultat.
ReDim TSyn(1 To 5000, 1 To 14)
L = 0
For Each Code In Gigogne(TableUniqueCréée, 2) ' Renvoie une Collection d'éléments de type SsGr à raison d'un pour chaque Code (colonne 2).
CEstLeDébut = True: IlFautAvancer = True
LDéb = L + 1
For Each Détail In Code.Co
CEstUneSuite3ou4 = Détail(0) > 2
If CEstLeDébut And CEstUneSuite3ou4 Then Exit For
If CEstLeDébut Then Dsgn = Détail(3) Else Détail(3) = Dsgn
If CEstUneSuite3ou4 Then IlFautAvancer = True
If IlFautAvancer Then L = L + 1
If Détail(7) = "R" Then Détail(7) = "Rupture"
If Détail(0) = 3 Then Détail(12) = Détail(12) + Détail(14)
For C = 1 To 13
If Not IsEmpty(Détail(C)) And IsEmpty(TSyn(L, C)) Then TSyn(L, C) = Détail(C)
Next C
CEstLeDébut = False: IlFautAvancer = CEstUneSuite3ou4: Next Détail
If L = LDéb + 1 Then
TSyn(LDéb, 1) = TSyn(L, 1)
For C = 11 To 13: TSyn(LDéb, C) = TSyn(L, C): Next C
For C = 1 To 13: TSyn(L, C) = Empty: Next C
L = L - 1
ElseIf L > LDéb Then
TSyn(LDéb, 11) = "=SUBTOTAL(9,OFFSET([@[Qté Cdée]],1,0," & L - LDéb & ",1))"
TSyn(LDéb, 12) = "=SUBTOTAL(9,OFFSET([@[Qté Prép]],1,0," & L - LDéb & ",1))"
End If
Next Code
With Me.ListObjects(1)
If .ListRows.Count > L Then .ListRows(L + 1).Range.Resize(.ListRows.Count - L).Delete xlShiftUp
Me.[A2:N5001].ClearContents
.DataBodyRange.Resize(L, 13).Value = TSyn
End With
End Sub
Voilà où j'en suis
