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

FCMLE44

XLDnaute Impliqué
Supporter XLD
Voilà ce que j'ai fait pour mes différentes demandes et cela fonctionne

Rapatriement du montant
VB:
LSp = LSp + 1: TSp(LSp, 1) = NomFeui

Calcul du total et des écarts

VB:
 Fpaiemt.Cells(LSp + 1, "AA").FormulaR1C1 = "=SUM(RC3:RC26)"
      Fpaiemt.Cells(LSp + 1, "AB").FormulaR1C1 = "=SUM(RC2-RC27)"

Il me reste à régler mon problème de format
 

FCMLE44

XLDnaute Impliqué
Supporter XLD
Bonjour

J'avance doucement dans mon projet et je souhaiterais créer en plus une feuille Taux AT qui se présente comme exemple en pièce jointe

Les taux seraient listés par colonne pour chaque code de siret

Voici ce que j'ai fait dans le même principe que ma feuille Suivi paiement

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, TAt(), LAt 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):
'ReDim TAt(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
      'With FRat.Cells(LAt, 1).Resize(, 8): .Font.Bold = True: .Interior.Color = RGB(255, 240, 186): End With
      'With FRat.Cells(LAt, 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(LRc, 1).Resize(1):   .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"
      'LAt = LAt + 1: TAt(LAt, 1) = "Montant": TAt(LAt + 1, 1) = "Dads": TAt(LAt + 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
      'LAt = LAp + 1: TAt(LAt, 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
            'TAt(LAt, 2) = TAt(LAt, 2) + Détail(36)
            TSp(LSp, 2) = TSp(LSp, 2) + Détail(38)
            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)"
      Fpaiemt.Cells(LSp + 1, "AA").FormulaR1C1 = "=SUM(RC3:RC26)"
      Fpaiemt.Cells(LSp + 1, "AB").FormulaR1C1 = "=SUM(RC2-RC27)"
      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.[A2:B1001].Value = TSp
'FRat.[A2:B1001].Value = TAt
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

A mon avis comme je mets LAt ca prend par ligne mais je souhaiterais par colonne
 

Pièces jointes

  • Feuille AT.xlsx
    14 KB · Affichages: 35

Dranreb

XLDnaute Barbatruc
Par exemple, si vous vous débrouillez comme un grand
pour qu'une variable LAt As Long contienne un numéro de ligne
et qu'une autre variable CAt As Long contienne un numéro de colonne,
TAt(LAt + 1, CAt) = TAt(LAt + 1, CAt) + Détail(25) additionnerait un montant colonne 25 à la ligne qui suit celle contenue dans LAt et à la colonne CAt .
 

FCMLE44

XLDnaute Impliqué
Supporter XLD
Bonjour

J'ai fait ca
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, TAt(), LAt As Long, CAt 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):
ReDim TAt(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 + 1: TSp(LSp, 1) = NomFeui
      CAt = CAt + 1: TAt(CAt, 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
            TAt(LAt + 1, CAt) = TAt(LAt + 1, CAt) + Détail(25)
            TSp(LSp, 2) = TSp(LSp, 2) + Détail(38)
            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)"
      Fpaiemt.Cells(LSp + 1, "AA").FormulaR1C1 = "=SUM(RC3:RC26)"
      Fpaiemt.Cells(LSp + 1, "AB").FormulaR1C1 = "=SUM(RC2-RC27)"
      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.[A2:B1001].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

Et cela bug sur

VB:
TAt(LAt + 1, CAt) = TAt(LAt + 1, CAt) + Détail(25)

????
 

Dranreb

XLDnaute Barbatruc
Bonjour.
Allez en débogage et vérifiez les valeurs de LAt et de CAt, elles sont peut être mal initialisées et en dehors des dimensions du tableau
De fait je ne vois aucune incrémentation de CAt à chaque fois qu'il faut ouvrir une nouvelle colonne. (juste après un de For Each In je suppose)
Ah, si, il y en a une, trop haut je crois, au début de chaque code SIRET. Là c'est LAt qui devrait être incrémenté et CAt seulement remis au début…
 
Dernière édition:

FCMLE44

XLDnaute Impliqué
Supporter XLD
Voilà ce que j'ai fait mais ca bloque toujours

VB:
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 + 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
         CAt = CAt + 1
         TAt(CAt, 1) = LibCot.Id: TAt(CAt, 2) = CodCot.Id: TAt(CAt, 3) = Commune.Id
         TAt(CAt, 4) = Qualif.Id: TAt(CAt, 6) = TxCoti.Id: TAt(CAt, 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
            TAt(LAt + 1, CAt) = TAt(LAt + 1, CAt) + Détail(25)
            TSp(LSp, 2) = TSp(LSp, 2) + Détail(38)
            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)"
      Fpaiemt.Cells(LSp + 1, "AA").FormulaR1C1 = "=SUM(RC3:RC26)"
      Fpaiemt.Cells(LSp + 1, "AB").FormulaR1C1 = "=SUM(RC2-RC27)"
      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.[A2:B1001].Value = TSp
FAt.[A2:Z1001].Value = TAt
 

Dranreb

XLDnaute Barbatruc
Vous avez vérifié au moment du plantage la valeur de CAt en mettant notamment un espion dessus ?
Vous oubliez de le remettre à 1 à chaque fois que vous avancez (trop peu d'ailleurs) dans LAt. Et dans la première ligne de chaque paquet vous ne mettez rien ?
Comme TAt(LAt, CAt) = Qualif.Id par exemple ? (en supposanrt que le CAt = CAt + 1 soit fait juste après le For Each Qualif In…
 

FCMLE44

XLDnaute Impliqué
Supporter XLD
J'essaie de comprendre mais je n'y arrive pas trop. Je vous remercie de passer du temps à m'aider mais c'est mon dernier morceau et je veux absolument au bout

Pouvez- vous me dire où et ce qu'il faut que j'écrive pour en finir

Merci
 

Pièces jointes

  • Feuille AT.xlsx
    14 KB · Affichages: 35

Dranreb

XLDnaute Barbatruc
Encore novice ?
Avec tous les exemples à étudier…
Puis d'abord je ne sais même pas ce que vous voulez y mettre dans vos lignes jaunes et vos lignes rose: il n'y a toujours qu'une feuille dans le classeur que vous joignez.
Ce qui va dans la jaune ça correspond bien à l'Id d'un des SsGr ?
Si oui, juste après le For Each CeSsGrLà In LeSsGrPrécédent.Co vous faites CAt = CAt + 1 puis TAt(LAt, CAt) = CeSsGrLà.Id pour ouvrir et mettre cet Id en titre de la nouvelle colonne. C'est pas difficile, bon sang !
Ça marche un peu comme le TRc(LRc, C) sauf que le C est calculé différemment et d'après ce que l'ai compris il avancerait plutôt un peu comme les L… des autre rapports, alors il ne faut pas prendre C mais CAt qui sera conservé entre les différents passages de boucles. N'oubliez pas de le remettre CAt = 1 à chaque fois que vous commencez un nouveau paquet de lignes en ajoutant au total 4 ou 5 à LAt comme on le fait pour LRc.
 
Dernière édition:

Discussions similaires