1. Ce site utilise des "témoins de connexion" (cookies) conformes aux textes de l'Union Européenne. Continuer à naviguer sur nos pages vaut acceptation de notre règlement en la matière. En savoir plus.

XL 2013 Regroupement de données selon plusieurs critères..

Discussion dans 'Forum Excel' démarrée par anri0610, 6 Août 2018.

  1. Dranreb

    Dranreb XLDnaute Barbatruc

    Inscrit depuis le :
    31 Janvier 2011
    Messages :
    14632
    "J'aime" reçus :
    887
    Sexe :
    Masculin
    Habite à:
    Belfort
    Utilise:
    Excel 2016 (PC)
    J'ai dit ActiveSheet, en un seul mot, pas active sheet
     
  2. anri0610

    anri0610 XLDnaute Junior

    Inscrit depuis le :
    6 Août 2018
    Messages :
    50
    "J'aime" reçus :
    0
    Sexe :
    Masculin
    Habite à:
    Hokkaido
    Utilise:
    Excel 2013 (PC)
    je viens de me rendre compte excuser moi ,
    avec ma macro CAD dans mon fichier test,
    en fonction des colonnes j'avais selon certains critères(>25, =2500, >200,etc) mes valeurs en rouge,
    avec ma macro apsaly que j'avais régler tout bêtement pour transposer cela me copiait les données telles quelles,
    atout qui malheureusement a disparut avec gigogne y aurait il une possibilité ?
     
  3. Dranreb

    Dranreb XLDnaute Barbatruc

    Inscrit depuis le :
    31 Janvier 2011
    Messages :
    14632
    "J'aime" reçus :
    887
    Sexe :
    Masculin
    Habite à:
    Belfort
    Utilise:
    Excel 2016 (PC)
    Il devrait être possible de mettre des mises en forme conditionnelles, mais elle seraient peut être un peu compliquées
    Il serait possible de mettre une couleur de fond à chaque paquet selon la valeur
     
  4. anri0610

    anri0610 XLDnaute Junior

    Inscrit depuis le :
    6 Août 2018
    Messages :
    50
    "J'aime" reçus :
    0
    Sexe :
    Masculin
    Habite à:
    Hokkaido
    Utilise:
    Excel 2013 (PC)
    je ne m’était pas tromper pour l’écriture du code (je ferais attention a ne plus faire de faute pour du language de code)
    mais pardon,
    j'avais du manquer quelque chose j'ai réussi !

    Ne me reste plus que le regroupement des noms de la colonne A et mes valeurs de filtre en rouges s'il vous plait, votre aide est précieuse !
     
  5. Dranreb

    Dranreb XLDnaute Barbatruc

    Inscrit depuis le :
    31 Janvier 2011
    Messages :
    14632
    "J'aime" reçus :
    887
    Sexe :
    Masculin
    Habite à:
    Belfort
    Utilise:
    Excel 2016 (PC)
    Il faut me donner plus de précisions si vous voulez que la macro Regrouper colore les paquets selon les valeurs de la somme.
     
  6. anri0610

    anri0610 XLDnaute Junior

    Inscrit depuis le :
    6 Août 2018
    Messages :
    50
    "J'aime" reçus :
    0
    Sexe :
    Masculin
    Habite à:
    Hokkaido
    Utilise:
    Excel 2013 (PC)
    Voici pour l'instant les seules conditions que j'utilise,

    Code (Visual Basic):
        Range("C2").Select
        Range(Selection, Selection.End(xlDown)).Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _
            Formula1:="=25"
        Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
        With Selection.FormatConditions(1).Font
            .Color = -16776961
            .TintAndShade = 0
        End With
        Selection.FormatConditions(1).StopIfTrue = False
        Range("B2").Select
        Range(Selection, Selection.End(xlDown)).Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _
            Formula1:="=200"
        Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
        With Selection.FormatConditions(1).Font
            .Color = -16776961
            .TintAndShade = 0
        End With
        Selection.FormatConditions(1).StopIfTrue = False
        Range("D2").Select
        Range(Selection, Selection.End(xlDown)).Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
            Formula1:="=2150"
        Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
        With Selection.FormatConditions(1).Font
            .Color = -16776961
            .TintAndShade = 0
        End With
        Selection.FormatConditions(1).StopIfTrue = False
     
  7. anri0610

    anri0610 XLDnaute Junior

    Inscrit depuis le :
    6 Août 2018
    Messages :
    50
    "J'aime" reçus :
    0
    Sexe :
    Masculin
    Habite à:
    Hokkaido
    Utilise:
    Excel 2013 (PC)
    j'ai essayer gigogne avec un nouveau fichier un petit peu plus embêtant
    et j'obtient un étrange résultat.. uniquement les sommes sont répétées?
     

    Pièces jointes:

  8. Dranreb

    Dranreb XLDnaute Barbatruc

    Inscrit depuis le :
    31 Janvier 2011
    Messages :
    14632
    "J'aime" reçus :
    887
    Sexe :
    Masculin
    Habite à:
    Belfort
    Utilise:
    Excel 2016 (PC)
    Pour la questions d'avant, essayez comme ça :
    Code (Visual Basic):
    Sub Regrouper()
       Dim TR(), LR&, Arg1 As SsGr, Arg2 As SsGr, Arg3 As SsGr, Arg4 As SsGr, _
          RngCbl As Range
       ReDim TR(1 To ActiveSheet.UsedRange.Rows.Count * 5, 1 To 1)
       Set RngCbl = ActiveSheet.[G2].Resize(UBound(TR, 1))
       RngCbl.Font.Color = 0
       For Each Arg2 In Gigogne(ActiveSheet.[A2:E2], -2, -3, -4, 1)
          For Each Arg3 In Arg2.Co
             For Each Arg4 In Arg3.Co
                For Each Arg1 In Arg4.Co
                   LR = LR + 1: TR(LR, 1) = Arg1.Id
                   LR = LR + 1: TR(LR, 1) = Arg2.Id: If Arg2.Id = 25 Then RngCbl(LR, 1).Font.Color = -16776961
                   LR = LR + 1: TR(LR, 1) = Arg3.Id: If Arg3.Id = 200 Then RngCbl(LR, 1).Font.Color = -16776961
                   LR = LR + 1: TR(LR, 1) = Arg4.Id: If Arg4.Id = 2150 Then RngCbl(LR, 1).Font.Color = -16776961
                   LR = LR + 1: TR(LR, 1) = Arg4.Somme(5)
                   Next Arg1, Arg4, Arg3, Arg2
          RngCbl.Value = TR
       End Sub
     
    Dernière édition: 9 Août 2018
  9. Dranreb

    Dranreb XLDnaute Barbatruc

    Inscrit depuis le :
    31 Janvier 2011
    Messages :
    14632
    "J'aime" reçus :
    887
    Sexe :
    Masculin
    Habite à:
    Belfort
    Utilise:
    Excel 2016 (PC)
    C'est sûr que c'est beaucoup moins lisible quand il y a un nombre au lieu d'un texte en colonne A !
    Pour repérer visuellement les paquets, je veux dire. Depus le début cette disposition me parait anormale d'ailleurs, mais c'est vous qui voyez.
     
  10. anri0610

    anri0610 XLDnaute Junior

    Inscrit depuis le :
    6 Août 2018
    Messages :
    50
    "J'aime" reçus :
    0
    Sexe :
    Masculin
    Habite à:
    Hokkaido
    Utilise:
    Excel 2013 (PC)
    je vous envoi un exemple du résultat idéal souhaite ,
    j'ai eu un soucis également avec l'ordre des données pour les valeurs présentes aux lignes 57,58.
    (qui se retrouvent mélangées au lieu d’être a la fin)

    (je pense cela un détail mais dans le doute je préfère le préciser,
    je pensais essayer après tout ça de faire en sorte que,
    les valeur de la colonne C changent sous cette condition, si égal a 25 alors modifier en 24.)
     

    Pièces jointes:

  11. anri0610

    anri0610 XLDnaute Junior

    Inscrit depuis le :
    6 Août 2018
    Messages :
    50
    "J'aime" reçus :
    0
    Sexe :
    Masculin
    Habite à:
    Hokkaido
    Utilise:
    Excel 2013 (PC)
    est ce a rajouter ou bien a remplacer ?
    (en remplaçant je n'ai plus de réaction.)
     
  12. anri0610

    anri0610 XLDnaute Junior

    Inscrit depuis le :
    6 Août 2018
    Messages :
    50
    "J'aime" reçus :
    0
    Sexe :
    Masculin
    Habite à:
    Hokkaido
    Utilise:
    Excel 2013 (PC)
    Cette disposition est toute a fait anormale, je suis seulement dans l'obligation de mettre les valeurs a la verticales sinon les données sont
    malheureusement inutilisables, pour la suite avec un autre logiciel.
    je souhaitait cependant si c’était possible a faire en sorte qu'après chaque regroupement de données on laisse un espace (une ligne) puis passer
    a la suite , ce qui serait plus lisible déjà , je ne sais trop juger la
    difficulté de ces modifications donc je n'ai demander de l'aide que sur l'essentiel.

    ps: je dois rentrer , je vous lit et réponds demain, encore merci pour votre aide ! :)
     
  13. Dranreb

    Dranreb XLDnaute Barbatruc

    Inscrit depuis le :
    31 Janvier 2011
    Messages :
    14632
    "J'aime" reçus :
    887
    Sexe :
    Masculin
    Habite à:
    Belfort
    Utilise:
    Excel 2016 (PC)
    Et pour l'autre jeu de données, c'est une autre procédure alors ? La colonne E des données doit elle être cumulée sur toute la combinaison de valeurs des colonnes B:D toutes valeurs confondues de la colonne A ?
     
    Dernière édition: 9 Août 2018
  14. Dranreb

    Dranreb XLDnaute Barbatruc

    Inscrit depuis le :
    31 Janvier 2011
    Messages :
    14632
    "J'aime" reçus :
    887
    Sexe :
    Masculin
    Habite à:
    Belfort
    Utilise:
    Excel 2016 (PC)
    Essayez comme ça :
    Code (Visual Basic):
    Sub Regrouper2()
       Dim TR(), LR&, Arg1 As SsGr, Arg2 As SsGr, Arg3 As SsGr, Arg4 As SsGr, _
          TTit(), RngCbl As Range, TJoin() As String, J As Long
       TTit = ActiveSheet.[A1:E1].Value
       ReDim TR(1 To 100000, 1 To 2)
       Set RngCbl = ActiveSheet.[K2].Resize(UBound(TR, 1), 2)
       RngCbl.Font.Color = 0
       For Each Arg2 In Gigogne(ActiveSheet.[A2:E2], -2, -3, -4, 1)
          For Each Arg3 In Arg2.Co
             For Each Arg4 In Arg3.Co
                ReDim TJoin(1 To Arg4.Count): J = 0
                For Each Arg1 In Arg4.Co: J = J + 1: TJoin(J) = Arg1.Id: Next Arg1
                LR = LR + 1: TR(LR, 1) = TTit(1, 1): TR(LR, 2) = "'" & Join(TJoin, ".")
                LR = LR + 1: TR(LR, 1) = TTit(1, 2): TR(LR, 2) = Arg2.Id: If Arg2.Id > 200 Then RngCbl(LR, 2).Font.Color = -16776961
                LR = LR + 1: TR(LR, 1) = TTit(1, 3): TR(LR, 2) = Arg3.Id: If Arg3.Id > 25 Then RngCbl(LR, 2).Font.Color = -16776961
                LR = LR + 1: TR(LR, 1) = TTit(1, 4): TR(LR, 2) = Arg4.Id: If Arg4.Id = 2150 Then RngCbl(LR, 2).Font.Color = -16776961
                LR = LR + 1: TR(LR, 1) = TTit(1, 5): TR(LR, 2) = Arg4.Somme(5)
                Next Arg4, Arg3, Arg2
          RngCbl.Value = TR
       End Sub
     
    Dernière édition: 9 Août 2018
  15. job75

    job75 XLDnaute Barbatruc

    Inscrit depuis le :
    15 Mai 2008
    Messages :
    25769
    "J'aime" reçus :
    2191
    Sexe :
    Masculin
    Habite à:
    Paris
    Utilise:
    Excel 2013 (PC)
    Bonjour anri0610, Bernard, le forum,

    Pour obtenir le "résultat idéal souhaité" :
    Code (Text):
    Sub Grouper()
    Dim dest As Range, P As Range, t, ub&, a(), i&, k%, n&, x$, j&
    Application.ScreenUpdating = False
    With ActiveSheet 'si la macro est dans un autre fichier
        Set dest = .[G2] '1ère cellule des résultats, à adapter
        Set P = .[A1].CurrentRegion.Resize(, 5) '5 colonnes
        t = P
        ub = UBound(t)
        ReDim a(1 To ub * UBound(t, 2), 1 To 1)
        For i = 2 To ub
            x = t(i, 2) & t(i, 3) & t(i, 4)
            For k = 1 To 5
                n = n + 1: a(n, 1) = t(i, k)
            Next
            For j = i + 1 To ub
                If t(j, 2) & t(j, 3) & t(j, 4) <> x Then Exit For
                If t(j, 1) <> t(j - 1, 1) Then a(n - 4, 1) = a(n - 4, 1) & "." & t(j, 1)
                a(n, 1) = a(n, 1) + t(j, 5)
            Next
            P.Rows(i).Copy
            dest(n - 4).PasteSpecial xlPasteFormats, Transpose:=True 'collage spécial
            i = j - 1
        Next i
        Application.CutCopyMode = 0
        With dest
            If n Then .Resize(n) = a
            .Offset(n).Resize(Rows.Count - n - .Row + 1).Delete xlUp 'RAZ en dessous
            .EntireColumn.AutoFit 'ajustement largeur
        End With
        Application.GoTo .[A1], True 'cadrage
        With .UsedRange: End With 'actualise la barre de defilement verticale
    End With
    End Sub
    Les formats sont copiés avec transposition, cela prendra évidemment du temps sur un gros fichier.

    Fichier joint.

    A+
     

    Pièces jointes:

    Dernière édition: 9 Août 2018
  16. Dranreb

    Dranreb XLDnaute Barbatruc

    Inscrit depuis le :
    31 Janvier 2011
    Messages :
    14632
    "J'aime" reçus :
    887
    Sexe :
    Masculin
    Habite à:
    Belfort
    Utilise:
    Excel 2016 (PC)
    Avec un espace entre chaque paquet :
    Code (Visual Basic):
    Sub Regrouper()
       Dim TR(), LR&, Arg1 As SsGr, Arg2 As SsGr, Arg3 As SsGr, Arg4 As SsGr, _
          TTit(), RngCbl As Range, TJoin() As String, J As Long, RngPoliceRg As Range
       TTit = ActiveSheet.[A1:E1].Value
       ReDim TR(1 To 100000, 1 To 3)
       Set RngCbl = ActiveSheet.[G2].Resize(UBound(TR, 1), 3)
       RngCbl.Font.Color = 0
       For Each Arg2 In Gigogne(ActiveSheet.[A2:E2], -2, -4, -3, 1)
          For Each Arg4 In Arg2.Co
             For Each Arg3 In Arg4.Co
                ReDim TJoin(1 To Arg3.Count): J = 0
                For Each Arg1 In Arg3.Co: J = J + 1: TJoin(J) = Arg1.Id: Next Arg1
                LR = LR + 1: TR(LR, 1) = TTit(1, 1): TR(LR, 2) = "'" & Join(TJoin, ".")
                LR = LR + 1: TR(LR, 1) = TTit(1, 2): TR(LR, 2) = Arg2.Id: If Arg2.Id > 200 Then TR(LR, 3) = 1
                LR = LR + 1: TR(LR, 1) = TTit(1, 3): TR(LR, 2) = Arg3.Id: If Arg3.Id > 25 Then TR(LR, 3) = 1
                LR = LR + 1: TR(LR, 1) = TTit(1, 4): TR(LR, 2) = Arg4.Id: If Arg4.Id = 2150 Then TR(LR, 3) = 1
                LR = LR + 1: TR(LR, 1) = TTit(1, 5): TR(LR, 2) = Arg4.Somme(5)
                LR = LR + 1
                Next Arg3, Arg4, Arg2
       RngCbl.Value = TR
       On Error Resume Next: Set RngCbl = RngCbl.Columns(3).SpecialCells(xlCellTypeConstants)
       If Err Then Exit Sub
       RngCbl.Offset(, -1).Font.Color = &HFF&
       RngCbl.EntireColumn.Delete
       End Sub
     
    Ah oui attention, l'ordre de classement a changé. Voir si cette procédure est quand même adaptée aux deux configurations.
     
  17. job75

    job75 XLDnaute Barbatruc

    Inscrit depuis le :
    15 Mai 2008
    Messages :
    25769
    "J'aime" reçus :
    2191
    Sexe :
    Masculin
    Habite à:
    Paris
    Utilise:
    Excel 2013 (PC)
    Re,

    J'ai testé ma solution du post #55 après avoir copié le tableau A2:E58 jusqu'à la ligne 5701.

    La macro s'exécute chez moi en 2 minutes environ, c'est beaucoup trop long.

    Comme l'a suggéré Bernard il faut donc recréer la MFC (2 conditions) en colonne G :
    Code (Text):
    Sub Grouper()
    Dim dest As Range, t, ub&, a(), i&, k%, n&, x$, j&
    Application.ScreenUpdating = False
    With ActiveSheet 'si la macro est dans un autre fichier
        Set dest = .[G2] '1ère cellule des résultats, à adapter
        t = .[A1].CurrentRegion.Resize(, 5) '5 colonnes
        ub = UBound(t)
        ReDim a(1 To ub * UBound(t, 2), 1 To 1)
        For i = 2 To ub
            x = t(i, 2) & t(i, 3) & t(i, 4)
            For k = 1 To 5
                n = n + 1: a(n, 1) = t(i, k)
            Next
            For j = i + 1 To ub
                If t(j, 2) & t(j, 3) & t(j, 4) <> x Then Exit For
                If t(j, 1) <> t(j - 1, 1) Then a(n - 4, 1) = a(n - 4, 1) & "." & t(j, 1)
                a(n, 1) = a(n, 1) + t(j, 5)
            Next
            i = j - 1
        Next i
        With dest
            If n Then
                .Resize(n) = a
                '---copie de la 1ère condition de la MFC---
                .Parent.[A2].Copy
                .Resize(n).PasteSpecial xlPasteFormats  'collage spécial
                Application.CutCopyMode = 0
                '---2ème condition de la MFC---
                .Resize(n).FormatConditions.Add(Type:=xlExpression, Formula1:= _
                    "=ET(MOD(LIGNE()-LIGNE(" & dest.Address & ");5)=2;" & dest.Address(0, 0) & ">25)") _
                        .Font.Color = vbRed 'police rouge
            End If
            .Offset(n).Resize(Rows.Count - n - .Row + 1).Delete xlUp 'RAZ en dessous
            .EntireColumn.AutoFit 'ajustement largeur
        End With
        Application.GoTo .[A1], True 'cadrage
        With .UsedRange: End With 'actualise la barre de défilement verticale
    End With
    End Sub
    Fichier (2), maintenant sur 5700 lignes la macro s'exécute en 0,12 seconde.

    A+
     

    Pièces jointes:

  18. anri0610

    anri0610 XLDnaute Junior

    Inscrit depuis le :
    6 Août 2018
    Messages :
    50
    "J'aime" reçus :
    0
    Sexe :
    Masculin
    Habite à:
    Hokkaido
    Utilise:
    Excel 2013 (PC)
    Tout d'abords un grand grand merci !!! le résultat est bluffant, je n'imaginait pas mieux !

    il me reste 2,3 petites requêtes et je crois bien que ce sera parfait !
    désoler de dépendre complètement de vous..

    1-

    Je souhaiterai toujours si possible,
    que dans le regroupement (colonne H) des données de la colonne A,
    (uniquement bien sur pour les conditions de regroupement actuelles)
    que les doubles soient supprimer que ce soit des lettres ou des chiffres,

    ex= AW-1.AW-3 -> AW-1.3

    ex= 301.301.307.308 -> 301.307.308

    par contre dans ce cas la:

    ex= AW-1.AD-1.AW-2.AD-2 -> AW-1.2.AD-1.2 (si cela semble trop compliquer laisser comme tel AW-1.AD-1.AW-2.AD-2)

    La réflexion est telle que si les lettres sont identique alors supprimer les valeur en double,
    cependant si les lettres diffèrent (dans ce cas la AD-) regrouper les cas identiques ,
    ou bien seulement ne pas confondre (en tant que doublon et supprimer juste les chiffres) ce qui donnerait AW-1.AD.AW-2.AD .



    2-

    j'ai compris que l'espace correspondait a :
    Code (Visual Basic):
    LR = LR + 1
    cependant je souhaiterai que cet espace s' effectue uniquement si la valeur de la colonne B diffère .
    j'ai bien sur chercher a le faire par moi même mais je ne trouve toujours pas de solution .
    j'ai alors essayer comme ça:
    Code (Visual Basic):
     For Each Arg1 In Arg3.Co: J = J + 1: TJoin(J) = Arg1.Id: Next Arg1
                LR = LR + 1: TR(LR, 1) = TTit(1, 1): TR(LR, 2) = "'" & Join(TJoin, ".")
                LR = LR + 1: TR(LR, 1) = TTit(1, 2): TR(LR, 2) = Arg2.Id: If Arg2.Id > 200 Then TR(LR, 3) = 1
                LR = LR + 1: TR(LR, 1) = TTit(1, 3): TR(LR, 2) = Arg3.Id: If Arg3.Id > 25 Then TR(LR, 3) = 1
                LR = LR + 1: TR(LR, 1) = TTit(1, 4): TR(LR, 2) = Arg4.Id: If Arg4.Id = 2150 Then TR(LR, 3) = 1
                LR = LR + 1: TR(LR, 1) = TTit(1, 5): TR(LR, 2) = Arg4.Somme(5)
                If Arg2.Id <> Arg2.Id Then LR = LR + 1
                Next Arg3, Arg4, Arg2
    ou:
    Code (Visual Basic):
     If Range("B" & Ligne) <> Range("B" & Ligne - 1) Then LR = LR + 1
     
    Et bien d'autres mais évidemment cela ne marche pas .


    ps=(Serait ce possible d'ajouter une condition pour que la somme des valeur de la colonne E ,
    qui est transposée en colonne H soit affichée en rouge lorsque Égal ou Inférieur a 5 ?)
    Je vient de réussir pour ca! :)
    comme ca:
    Code (Visual Basic):
    LR = LR + 1: TR(LR, 1) = TTit(1, 5): TR(LR, 2) = Arg4.Somme(5): If Arg4.Somme(5) <= 5 Then TR(LR, 3) = 1
     
     

    Pièces jointes:

    Dernière édition: 10 Août 2018
  19. job75

    job75 XLDnaute Barbatruc

    Inscrit depuis le :
    15 Mai 2008
    Messages :
    25769
    "J'aime" reçus :
    2191
    Sexe :
    Masculin
    Habite à:
    Paris
    Utilise:
    Excel 2013 (PC)
    Bonjour anri0610, le forum,

    Vous ignorez les solutions que je propose mais ça m'est égal car il n'y a pas que vous que ça peut intéresser.

    Et je découvre au compte-goutte vos desiderata.

    Ici avec 2 colonnes de résultats et une 3ème condition pour la MFC en colonne H :
    Code (Text):
    Sub Grouper()
    Dim dest As Range, t, ub&, a(), i&, k%, n&, x$, j&
    Application.ScreenUpdating = False
    With ActiveSheet 'si la macro est dans un autre fichier
        Set dest = .[G2] '1ère cellule des résultats, à adapter
        t = .[A1].CurrentRegion.Resize(, 5) '5 colonnes
        ub = UBound(t)
        ReDim a(1 To ub * UBound(t, 2), 1 To 2) '2 colonnes
        For i = 2 To ub
            x = t(i, 2) & t(i, 3) & t(i, 4)
            For k = 1 To 5
                n = n + 1: a(n, 1) = t(1, k): a(n, 2) = t(i, k)
            Next k
            For j = i + 1 To ub
                If t(j, 2) & t(j, 3) & t(j, 4) <> x Then Exit For
                If t(j, 1) <> t(j - 1, 1) Then a(n - 4, 2) = a(n - 4, 2) & "." & t(j, 1)
                a(n, 2) = a(n, 2) + t(j, 5)
            Next j
            i = j - 1
        Next i
        With dest
            If n Then
                .Resize(n, 2) = a
                With dest(1, 2)
                    '---copie de la 1ère condition de la MFC---
                    .Parent.[A2].Copy
                    .Resize(n).PasteSpecial xlPasteFormats 'collage spécial
                    Application.CutCopyMode = 0
                    '---2ème condition de la MFC---
                    .Resize(n).FormatConditions.Add(Type:=xlExpression, Formula1:= _
                        "=ET(MOD(LIGNE()-LIGNE(" & .Address & ");5)=2;" & .Address(0) & ">25)") _
                            .Font.Color = vbRed 'police rouge
                    '---3ème condition de la MFC---
                    With .Resize(n).FormatConditions.Add(Type:=xlExpression, Formula1:= _
                        "=ET(MOD(LIGNE()-LIGNE(" & .Address & ");5)=4;" & .Address(0) & "<=5)")
                        .Font.Color = vbRed: .Font.Bold = True 'police rouge gras
                    End With
                End With
            End If
            .Offset(n).Resize(Rows.Count - n - .Row + 1, 2).Delete xlUp 'RAZ en dessous
            .Resize(, 2).EntireColumn.AutoFit 'ajustement largeur
        End With
        Application.GoTo .[A1], True 'cadrage
        With .UsedRange: End With 'actualise la barre de défilement verticale
    End With
    End Sub
    Fichier (3).

    Bonne journée.
     

    Pièces jointes:

  20. anri0610

    anri0610 XLDnaute Junior

    Inscrit depuis le :
    6 Août 2018
    Messages :
    50
    "J'aime" reçus :
    0
    Sexe :
    Masculin
    Habite à:
    Hokkaido
    Utilise:
    Excel 2013 (PC)
    Bonjour Job75,

    je vous assure que je n'ai ignorer aucun des posts qui m'ont été adresses,
    pardon pour ma réponse tardive et vous avoir donner ce sentiment , et merci encore pour toutes vos propositions !
    ( il m'est inconcevable d'ignorer une aide alors que je suis incapable de me débrouiller seul ! )
    et je suis d'accord avec vous cela peut servir a d'autres personnes mais aussi m'en apprendre plus sur les possibilités et la réflexion du codage !

    effectivement j'utilise actuellement les propositions de Dranreb qui m'ont apporter de suite le résultat désirer ,
    mais bien sur je regarde, je test et donne un feedback a toutes vos propositions ,
    je vous joint maintenant pour vos 2 derniers messages l'erreur et le résultat obtenu en screen!
     

    Pièces jointes:

Chargement...
Discussions similaires - Regroupement données selon Forum Date
XL 2010 PROGRAMME DE REGROUPEMENT DE DONNÉES Forum Excel 14 Octobre 2018
Regroupement de données de 2 tableaux Forum Excel 9 Janvier 2018
XL 2010 VBA regroupement de données par colonne Forum Excel 20 Juillet 2017
XL 2010 Regroupement de données dans un TCD Forum Excel 24 Août 2016
Help : macro de copie de données et de regroupement d'informations Forum Excel 22 Avril 2016

Partager cette page