XL 2010 Condenser les données d'un tableau

FCMLE44

XLDnaute Impliqué
Supporter XLD
Bonjour

Etape 2 de mon projet

Les onglets se créant automatiquement en fonction des données de la feuille DSN, je souhaite, pour chaque onglet créé condenser les données obtenues.

Feuille TC :
En ligne 4 colonne AN, je souhaite condenser les données se trouvant en colonne AD à AK (cf exemple fichier joint).

Lors de la mise à jour de chaque onglet via macro Balaye1, il se mettrait à jour automatiquement

Cordialement
 

Pièces jointes

  • DSN ESSAI.xls
    94 KB · Affichages: 51

Dranreb

XLDnaute Barbatruc
Ben y a qu'à prévoir un tableau supplémentaire.
TSp() par exemple (SP comme suivi paiement) avec LSp As Long pour son numéro de ligne courant, qu'on incrémente à chaque nouvelle feuille, en faisant juste après TSp(Lsp, 1) = NomFeui, et dans la boucle For Each Détail on fait TSp(LSp, 2) = TSp(Lsp, 2) + Détail(8). À la Fin on met les formules.
 

FCMLE44

XLDnaute Impliqué
Supporter XLD
Bonjour

J'ai modifié le code comme suit
VB:
Private Sub Worksheet_Deactivate()
Dim PlgDon As Range, Titres1(), Titres2(), CodSiret As SsGr, NumSiret As SsGr, F As Long, NomFeui As String, FDest As Worksheet, _
    TDt(), LDt As Long, TCd(), LCd As Long, TRc(), LRc As Long, TSp(), LSp As Long, CodCot As SsGr, Qualif As SsGr, TxCoti As SsGr, _
    TxAtT23003 As SsGr, LibCot As SsGr, Commune As SsGr, C As Long, Détail As Variant, DicRécap As New Dictionary, CléRécap$
Me.Cells(1, 38).Value = "M_COTIS Corrigé"
Set PlgDon = Me.UsedRange
If PlgDon.Rows.Count < 2 Then Exit Sub
Application.ScreenUpdating = False
Titres1 = PlgDon.Rows(1).Value: Titres2 = PlgDon(1, 30).Resize(, 8).Value
Set PlgDon = PlgDon.Rows(2).Resize(PlgDon.Rows.Count - 1)
PlgDon.Columns(38).FormulaR1C1 = "=IF(RC35=0,RC37,ROUND(RC34*(RC35+RC36)/100,0))"
With ThisWorkbook.Worksheets: For F = FSiret1.Index To .Count: .Item(F).Name = .Item(F).CodeName: Next F: End With
F = FSiret1.Index - 1
TRc = Intersect(FRécTab.[A2:G1000000], FRécTab.UsedRange).Value
For LRc = 1 To UBound(TRc, 1): DicRécap(TRc(LRc, 1) & "|" & TRc(LRc, 2) & "|" & TRc(LRc, 3)) = TRc(LRc, 4): Next LRc
LRc = 0
ReDim TRc(1 To 1000, 1 To 8): LRc = 0
For Each CodSiret In Gigogne(PlgDon.Rows(2).Resize(PlgDon.Rows.Count - 1), 1, 2, 31, 33, 35, 36, 30, 32)
   For Each NumSiret In CodSiret.Co
       NomFeui = CodSiret.Id & "-" & Right$(String$(5, Chr$(133)) & CStr(NumSiret.Id), 5)
      With ThisWorkbook.Worksheets: If F = .Count Then .Item(F).Copy After:=.Item(F)
         F = F + 1: Set FDest = .Item(F): FDest.Name = NomFeui: End With
      LRc = LRc + 1: For C = 1 To 8: TRc(LRc, C) = Choose(C, NomFeui, "Brut SS", "SS Plaf", _
         "Base CSG", "Net Imposable", "Cice", "Chômage", "Apprentis", "Montant déclaré"): Next C
      With FRécap.Cells(LRc, 1).Resize(, 8): .Font.Bold = True: .Interior.Color = RGB(255, 240, 186): End With
      With FRécap.Cells(LRc, 1).Resize(4):   .Font.Bold = True: .Interior.Color = RGB(255, 240, 186): End With
      LRc = LRc + 1: TRc(LRc, 1) = "Montant": TRc(LRc + 1, 1) = "Dads": TRc(LRc + 2, 1) = "Ecart"
      ReDim TDt(1 To 5000, 1 To 37), TCd(1 To 3000, 1 To 8): LDt = 0: LCd = 0
      For Each CodCot In NumSiret.Co: For Each Qualif In CodCot.Co: For Each TxCoti In Qualif.Co: For _
         Each TxAtT23003 In TxCoti.Co: For Each LibCot In TxAtT23003.Co: For Each Commune In LibCot.Co
         LCd = LCd + 1
         TSp(LSp, 1) = NomFeui
         TCd(LCd, 1) = LibCot.Id: TCd(LCd, 2) = CodCot.Id: TCd(LCd, 3) = Commune.Id
         TCd(LCd, 4) = Qualif.Id: TCd(LCd, 6) = TxCoti.Id: TCd(LCd, 7) = TxAtT23003.Id
         For Each Détail In Commune.Co
            LDt = LDt + 1
            For C = 1 To 37: TDt(LDt, C) = Détail(C): Next C
            TSp(LSp, 2) = TSp(LSp, 2) + Détail(8)
            TCd(LCd, 5) = TCd(LCd, 5) + Détail(34)
            TCd(LCd, 8) = TCd(LCd, 8) + Détail(38)

Et cela ne fonctionne pas. Je dois faire quelquechose d'incorrect

Cordialement
 

Dranreb

XLDnaute Barbatruc
Bonjour.
Je ne vois pas de Redim TSp(… pour lui attribuer des dimensions ni d'incrémentation de LSp pour avancer dedans.
De plus il me semble que TSp(LSp, 1) = NomFeui, trop bas, sera fait plus souvent que nécessaire, à chaque paquet de lignes aux critères tous pareils au lieu d'une fois seulement par CodeSiret/NumSiret.
Si j'ai bien compris ce que vous vouliez faire, ça doit en quelque sorte un peu marcher en même temps que TRc(LRc… plutôt qu'en même temps que TCd(LCd… sauf que LSp ne doit être incrémenté qu'une fois contrairement à LRc qui doit avancer de 5 au bout du compte à chaque fois.
 
Dernière édition:

Dranreb

XLDnaute Barbatruc
C'est bien ce qu'il me semblait. Faites comme ça, donc. Mettez LSp = LSp + 1: TSp(LSp, 1) = NomFeui avant For Each CodCot In NumSiret.Co
Et ajoutez d'abord: , TSp(1 to… derrière le Redim TRc comme on a fait plus bas pour TCd derrière le ReDim TDt. Vous pouvez même ajouter LSp = 0 derrière, si vous voulez, par simple souci d'homogénéité, mais ça ne sert à rien: il est à 0 par défaut au départ du moment qu'on ne s'en est pas servi auparavant pour autre chose.
 

FCMLE44

XLDnaute Impliqué
Supporter XLD
voici ce que ca donne si j'ai bien compris
VB:
Private Sub Worksheet_Deactivate()
Dim PlgDon As Range, Titres1(), Titres2(), CodSiret As SsGr, NumSiret As SsGr, F As Long, NomFeui As String, FDest As Worksheet, _
    TDt(), LDt As Long, TCd(), LCd As Long, TRc(), LRc As Long, TSp(), LSp As Long, CodCot As SsGr, Qualif As SsGr, TxCoti As SsGr, _
    TxAtT23003 As SsGr, LibCot As SsGr, Commune As SsGr, C As Long, Détail As Variant, DicRécap As New Dictionary, CléRécap$
Me.Cells(1, 38).Value = "M_COTIS Corrigé"
Set PlgDon = Me.UsedRange
If PlgDon.Rows.Count < 2 Then Exit Sub
Application.ScreenUpdating = False
Titres1 = PlgDon.Rows(1).Value: Titres2 = PlgDon(1, 30).Resize(, 8).Value
Set PlgDon = PlgDon.Rows(2).Resize(PlgDon.Rows.Count - 1)
PlgDon.Columns(38).FormulaR1C1 = "=IF(RC35=0,RC37,ROUND(RC34*(RC35+RC36)/100,0))"
With ThisWorkbook.Worksheets: For F = FSiret1.Index To .Count: .Item(F).Name = .Item(F).CodeName: Next F: End With
F = FSiret1.Index - 1
TRc = Intersect(FRécTab.[A2:G1000000], FRécTab.UsedRange).Value
For LRc = 1 To UBound(TRc, 1): DicRécap(TRc(LRc, 1) & "|" & TRc(LRc, 2) & "|" & TRc(LRc, 3)) = TRc(LRc, 4): Next LRc
LRc = 0
ReDim TRc(1 To 1000, 1 To 8): LRc = 0
ReDim TSp(1 To 1000, 1 To 8): LSp = 0
For Each CodSiret In Gigogne(PlgDon.Rows(2).Resize(PlgDon.Rows.Count - 1), 1, 2, 31, 33, 35, 36, 30, 32)
   For Each NumSiret In CodSiret.Co
       NomFeui = CodSiret.Id & "-" & Right$(String$(5, Chr$(133)) & CStr(NumSiret.Id), 5)
      With ThisWorkbook.Worksheets: If F = .Count Then .Item(F).Copy After:=.Item(F)
         F = F + 1: Set FDest = .Item(F): FDest.Name = NomFeui: End With
      LRc = LRc + 1: For C = 1 To 8: TRc(LRc, C) = Choose(C, NomFeui, "Brut SS", "SS Plaf", _
         "Base CSG", "Net Imposable", "Cice", "Chômage", "Apprentis", "Montant déclaré"): Next C
      With FRécap.Cells(LRc, 1).Resize(, 8): .Font.Bold = True: .Interior.Color = RGB(255, 240, 186): End With
      With FRécap.Cells(LRc, 1).Resize(4):   .Font.Bold = True: .Interior.Color = RGB(255, 240, 186): End With
      LRc = LRc + 1: TRc(LRc, 1) = "Montant": TRc(LRc + 1, 1) = "Dads": TRc(LRc + 2, 1) = "Ecart"
      ReDim TDt(1 To 5000, 1 To 37), TCd(1 To 3000, 1 To 8): LDt = 0: LCd = 0
      LSp = LSp + 1 = TSp(LSp, 1) = NomFeui
      For Each CodCot In NumSiret.Co: For Each Qualif In CodCot.Co: For Each TxCoti In Qualif.Co: For _
         Each TxAtT23003 In TxCoti.Co: For Each LibCot In TxAtT23003.Co: For Each Commune In LibCot.Co
         LCd = LCd + 1
         TCd(LCd, 1) = LibCot.Id: TCd(LCd, 2) = CodCot.Id: TCd(LCd, 3) = Commune.Id
         TCd(LCd, 4) = Qualif.Id: TCd(LCd, 6) = TxCoti.Id: TCd(LCd, 7) = TxAtT23003.Id
         For Each Détail In Commune.Co
            LDt = LDt + 1
            For C = 1 To 37: TDt(LDt, C) = Détail(C): Next C
            TSp(LSp, 2) = TSp(LSp, 2) + Détail(8)
            TCd(LCd, 5) = TCd(LCd, 5) + Détail(34)
            TCd(LCd, 8) = TCd(LCd, 8) + Détail(38)
            CléRécap = Détail(30) & "|" & Détail(31) & "|" & Détail(33)
            If DicRécap.Exists(CléRécap) Then C = DicRécap(CléRécap): TRc(LRc, C) = TRc(LRc, C) + Détail(34)
            Next Détail, Commune, LibCot, TxAtT23003, TxCoti, Qualif, CodCot
      FDest.[A1:AL1].Value = Titres1
      FDest.[AN1].Value = "TABLEAU RECAPITULATIF"
      FDest.[AO1].Value = NomFeui
      FDest.[A2:AL5001].Value = TDt
      FDest.[AN3:AU3].Value = Titres2
      FDest.[AN4:AU3003].Value = TCd
      FDest.Cells(LCd + 5, "AU").FormulaR1C1 = "=SUBTOTAL(9,R4C:R[-2]C)"
      FDest.Columns.AutoFit
      FDest.[A:AM].Columns.Hidden = True
      TRc(LRc + 1, 1) = "Dads": TRc(LRc + 2, 1) = "Ecart"
      LRc = LRc + 3
      Next NumSiret, CodSiret
FRécap.[A1:H1001].Value = TRc
For LRc = 4 To LRc Step 5: FRécap.Cells(LRc, 2).Resize(, 7).FormulaR1C1 = "=R[-2]C-R[-1]C": Next LRc
With ThisWorkbook.Worksheets
   While .Count > F: Application.DisplayAlerts = False: .Item(.Count).Delete
      Application.DisplayAlerts = True: Wend: End With
End Sub
Pour le format tel que je le souhaite dois je faire comme récap
 

FCMLE44

XLDnaute Impliqué
Supporter XLD
Bonjour

Si je mets FPaiemt.[A1:H1001].Value = TSp, ne faut il pas que j'aille renseigner des éléments ailleurs ?

VB:
Private Sub Worksheet_Deactivate()
Dim PlgDon As Range, Titres1(), Titres2(), CodSiret As SsGr, NumSiret As SsGr, F As Long, NomFeui As String, FDest As Worksheet, _
    TDt(), LDt As Long, TCd(), LCd As Long, TRc(), LRc As Long, TSp(), LSp As Long, CodCot As SsGr, Qualif As SsGr, TxCoti As SsGr, _
    TxAtT23003 As SsGr, LibCot As SsGr, Commune As SsGr, C As Long, Détail As Variant, DicRécap As New Dictionary, CléRécap$
Me.Cells(1, 38).Value = "M_COTIS Corrigé"
Set PlgDon = Me.UsedRange
If PlgDon.Rows.Count < 2 Then Exit Sub
Application.ScreenUpdating = False
Titres1 = PlgDon.Rows(1).Value: Titres2 = PlgDon(1, 30).Resize(, 8).Value
Set PlgDon = PlgDon.Rows(2).Resize(PlgDon.Rows.Count - 1)
PlgDon.Columns(38).FormulaR1C1 = "=IF(RC35=0,RC37,ROUND(RC34*(RC35+RC36)/100,0))"
With ThisWorkbook.Worksheets: For F = FSiret1.Index To .Count: .Item(F).Name = .Item(F).CodeName: Next F: End With
F = FSiret1.Index - 1
TRc = Intersect(FRécTab.[A2:G1000000], FRécTab.UsedRange).Value
For LRc = 1 To UBound(TRc, 1): DicRécap(TRc(LRc, 1) & "|" & TRc(LRc, 2) & "|" & TRc(LRc, 3)) = TRc(LRc, 4): Next LRc
LRc = 0
ReDim TRc(1 To 1000, 1 To 8): LRc = 0
ReDim TSp(1 To 1000, 1 To 8):
For Each CodSiret In Gigogne(PlgDon.Rows(2).Resize(PlgDon.Rows.Count - 1), 1, 2, 31, 33, 35, 36, 30, 32)
   For Each NumSiret In CodSiret.Co
       NomFeui = CodSiret.Id & "-" & Right$(String$(5, Chr$(133)) & CStr(NumSiret.Id), 5)
      With ThisWorkbook.Worksheets: If F = .Count Then .Item(F).Copy After:=.Item(F)
         F = F + 1: Set FDest = .Item(F): FDest.Name = NomFeui: End With
      LRc = LRc + 1: For C = 1 To 8: TRc(LRc, C) = Choose(C, NomFeui, "Brut SS", "SS Plaf", _
         "Base CSG", "Net Imposable", "Cice", "Chômage", "Apprentis"): Next C
      With FRécap.Cells(LRc, 1).Resize(, 8): .Font.Bold = True: .Interior.Color = RGB(255, 240, 186): End With
      With FRécap.Cells(LRc, 1).Resize(4):   .Font.Bold = True: .Interior.Color = RGB(255, 240, 186): End With
      LRc = LRc + 1: TRc(LRc, 1) = "Montant": TRc(LRc + 1, 1) = "Dads": TRc(LRc + 2, 1) = "Ecart"
      ReDim TDt(1 To 5000, 1 To 37), TCd(1 To 3000, 1 To 8): LDt = 0: LCd = 0
      LSp = LSp + 2: TSp(LSp, 2) = NomFeui
      For Each CodCot In NumSiret.Co: For Each Qualif In CodCot.Co: For Each TxCoti In Qualif.Co: For _
         Each TxAtT23003 In TxCoti.Co: For Each LibCot In TxAtT23003.Co: For Each Commune In LibCot.Co
         LCd = LCd + 1
         TCd(LCd, 1) = LibCot.Id: TCd(LCd, 2) = CodCot.Id: TCd(LCd, 3) = Commune.Id
         TCd(LCd, 4) = Qualif.Id: TCd(LCd, 6) = TxCoti.Id: TCd(LCd, 7) = TxAtT23003.Id
         For Each Détail In Commune.Co
            LDt = LDt + 1
            For C = 1 To 37: TDt(LDt, C) = Détail(C): Next C
            TSp(LSp, 2) = TSp(LSp, 2) + Détail(8)
            TCd(LCd, 5) = TCd(LCd, 5) + Détail(34)
            TCd(LCd, 8) = TCd(LCd, 8) + Détail(38)
            CléRécap = Détail(30) & "|" & Détail(31) & "|" & Détail(33)
            If DicRécap.Exists(CléRécap) Then C = DicRécap(CléRécap): TRc(LRc, C) = TRc(LRc, C) + Détail(34)
            Next Détail, Commune, LibCot, TxAtT23003, TxCoti, Qualif, CodCot
      FDest.[A1:AL1].Value = Titres1
      FDest.[AN1].Value = "TABLEAU RECAPITULATIF"
      FDest.[AO1].Value = NomFeui
      FDest.[A2:AL5001].Value = TDt
      FDest.[AN3:AU3].Value = Titres2
      FDest.[AN4:AU3003].Value = TCd
      FDest.Cells(LCd + 5, "AU").FormulaR1C1 = "=SUBTOTAL(9,R4C:R[-2]C)"
      FDest.Columns.AutoFit
      FDest.[A:AM].Columns.Hidden = True
      TRc(LRc + 1, 1) = "Dads": TRc(LRc + 2, 1) = "Ecart"
      LRc = LRc + 3
      Next NumSiret, CodSiret
FRécap.[A1:H1001].Value = TRc
FPaiemt.[A1:H1001].Value = TSp
For LRc = 4 To LRc Step 5: FRécap.Cells(LRc, 2).Resize(, 7).FormulaR1C1 = "=R[-2]C-R[-1]C": Next LRc
With ThisWorkbook.Worksheets
   While .Count > F: Application.DisplayAlerts = False: .Item(.Count).Delete
      Application.DisplayAlerts = True: Wend: End With
End Sub

Apparemment ca ne fonctionne pas
 

Dranreb

XLDnaute Barbatruc
Bonjour
Qu'est ce qui ne marche pas ?
Vérifiez à la rubrique Microsoft Excel Objets dans l'explorateur de projet si "FPaiemt" est il bien le nom que vous avez tapé dans la fenêtre de propriété de l'objet Worksheet qui représente la bonne feuille Excel.
 

FCMLE44

XLDnaute Impliqué
Supporter XLD
Merci c'est fait
Par contre le montant total de la colonne AU de chaque onglet ne remonte pas
et le format ne fonctionne pas malgré que j'ai modifié comme suit

VB:
With FRécap.Cells(LRc, 1).Resize(, 8): .Font.Bold = True: .Interior.Color = RGB(255, 240, 186): End With
      With FRécap.Cells(LRc, 1).Resize(4):   .Font.Bold = True: .Interior.Color = RGB(255, 240, 186): End With
      With Fpaiemt.Cells(LSp, 1).Resize(, 29): .Font.Bold = True: .Interior.Color = RGB(255, 240, 186): End With
      With Fpaiemt.Cells(LSp, 1).Resize(1):   .Font.Bold = True: .Interior.Color = RGB(255, 240, 186): End With
 

Dranreb

XLDnaute Barbatruc
Le mieux c'est de le cumuler indépendament dans une colonne de TSp. Il y a assez d'exemples de cumuls, non ?
Pourquoi vous mettez .Resize(1) ? Ça ne sert à rien, Fpaiemt.Cells(LSp, 1) ne représente déjà qu'une seule ligne, il n'y a pas lieu de le redimensionner à 1 ligne !

Êtes vous sûr de ne pas confondre le numéro de ligne et le numéro de colonne quand vous modifiez un élément de TSp ?
 

Dranreb

XLDnaute Barbatruc
En colonne B ?
Alors dans la boucle for each Détail:
TSp(LSp, 2) = TSp(LSp, 2) + Détail(38)
Mais ça va planter parce que plus haut vous y avez déjà mis NomFeui, en colonne 2 (B)
…du moins dans le code cité au #130
Ça doit déjà planter d'ailleurs parce que vous faitezs aussi déjà TSp(LSp, 2) = TSp(LSp, 2) + Détail(8)
Vous voulez décidément mettre plein de chose à la fois dans cette colonne 2 !
 
Dernière édition:

Discussions similaires

Statistiques des forums

Discussions
311 715
Messages
2 081 822
Membres
101 822
dernier inscrit
holale