Macro agréger plusieurs lignes si valeur d'une cellule ident

Le 03/05/2015 à 23:55

Bonsoir à tous,

Je vais essayer d'etre la plus claire possible.

Dans le fichier exemple ci joint vous verrez en colone D "titre" que parfois le meme code revient à plusieurs moments et pas forcément à la suite.

Je souhaiterais une macro qui regroupe en une seule ligne lorsqu'il y a répétition du méme code titre. Cela signifie qu'il faut aussi sommer les éléments en E, F, G et H.

Vous aurez compris que c'est similaire à un TCD mais je ne veux pas passer par ca car après j'ai des macros qui tournent.

En vous remerciant par avance,

Aline

89macro-regroupement.xlsm (9.53 Ko)
Le 04/05/2015 à 01:10

Bonsoir Aline, bonsoir le forum,

Peut-être comme ça. C'est plus que tordu mais ça semble fonctionner :

Sub Macro1()
Dim T As Worksheet 'déclare la variable T (onglet TEST)
Dim F As Worksheet 'déclare la variable F (onglet Feuil2)
Dim TC As Variant 'déclare la variable TC (Tableau de Cellules)
Dim K As Integer 'déclare la variable K (incrément)
Dim TL() As Variant 'déclare la variable TL (Tableau de Lignes)
Dim I As Integer 'déclare la variable I (Incrément)
Dim NO As Integer 'déclare la variable NO (Nombre d'Occurrences)
Dim J As Byte 'déclare la variable J (incrément)
Dim L As Integer 'déclare la variable L (incrément)
Dim M As Integer 'déclare la variable M (incrément)

Set T = Sheets("Test") 'définit l'onglet T
Set F = Sheets("Feuil2") 'définit l'onglet F
F.Range("A1").CurrentRegion.ClearContents 'efface d'éventuelles anciennes données
TC = T.Range("A1").CurrentRegion 'définit la tableau de cellules TC
K = 1 'initialise la variable K
For I = 1 To UBound(TC) 'boucle 1 : sur toutes les lignes I du tableau TC
    'définit le nombre d'occurrences NO de TC(I, 4) dans la colonne 4 de l'onglet T
    NO = Application.WorksheetFunction.CountIf(T.Columns(4), TC(I, 4))
    'redimensionne le tableau de lignes TL (autant de lignes que TC a de colonnes, K colonnes)
    ReDim Preserve TL(1 To UBound(TC, 2), 1 To K)
    If NO = 1 Then 'condition 1 : si il n'y a qu'une seule occurrence de TC(I,4) dans la colonne 4
        For J = 1 To UBound(TC, 2) 'boucle 2 : sur toutes les colonnes J de TC
            TL(J, K) = TC(I, J) 'récupère dans la ligne de TL la valeur de la colonne de TC (transposition)
        Next J 'prochaine colonne de la boucle 2
    Else 'sinon (condition 1 : si plusieurs occurrences de TC dans la colonne 4 de l'onglet T)
        For M = 1 To UBound(TL, 2) 'boucle 3 sur toutes les colonnes M de TL
            'si la valeur ligne I colonne 4 de TC est égale à la valeur ligne 4 colonne M de TL, va à l'étiquette "suite"
            If TC(I, 4) = TL(4, M) Then GoTo suite
        Next M 'prochaine colonne de la boucle 3
        For J = 1 To UBound(TC, 2) 'boucle 4 : sur toutes les colonnes J de TC
            TL(J, K) = TC(I, J) 'récupère dans la ligne de TL la valeur de la colonne de TC (transposition)
        Next J 'prochaine colonne de la boucle 4
        For L = 2 To UBound(TC, 1) 'boucle 5 sur toutes les lignes L du tableau de cellules TC (en partant de la seconde
            'condition 2 : si la valeur de la boucle 1 est égale à la valeur de la boucle 6 avec I diférent de L
            If TC(I, 4) = TC(L, 4) And I <> L Then
                TL(5, K) = TL(5, K) + TC(L, 5) 'ajoute les VB
                TL(6, K) = TL(6, K) + TC(L, 6) 'ajoute les ASD
                TL(7, K) = TL(7, K) + TC(L, 7) 'ajoute les SD
                TL(8, K) = TL(8, K) + TC(L, 8) 'ajoute les PDD
            End If 'fin de la condition 2
        Next L 'prochaine ligne de la boucle 5
    End If 'fin de la condition 1
    K = K + 1 'incrément K (rajoute une colonne à TL
suite: 'étiquette
Next I 'prochaine ligne de la boucle 1
'renvoie dans la cellule A1 (redimensionnée) de l'onglet F, le tanleau TL transposé
F.Range("A1").Resize(UBound(TL, 2), UBound(TL, 1)).Value = Application.Transpose(TL)
F.Range("E2:H" & F.Cells(Application.Rows.Count, 1).End(xlUp).Row).NumberFormat = _
   "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)" 'format de la plage des valeurs
End Sub
Le 04/05/2015 à 08:06

Bonjour Aline,

Salut ThauThème

Puisque la solution macro est déjà brillamment réussie ...

ci-joint, pour l'amusement... une solution sans macro ...

151macro-regroupement.xlsm (22.09 Ko)
Le 04/05/2015 à 09:28

Bonjour le fil, bonjour le forum,

C'est très très très énervant ! Je hais les formulistes... On devrait , je pense, leur interdire l'accès au forum. Bon je vais acheter une brouette de mouchoirs et pleurer. Mais je me vengerai... Non, je ne vais pas apprendre les formules ! Faut pas exagérer non plus... De toute manière il faut des neurones pour apprendre pareille barbarie et je suis en rupture de stock là...

Le 04/05/2015 à 12:10
ThauThème a écrit :

Bonjour le fil, bonjour le forum,

C'est très très très énervant ! Je hais les formulistes... On devrait , je pense, leur interdire l'accès au forum. Bon je vais acheter une brouette de mouchoirs et pleurer. Mais je me vengerai... Non, je ne vais pas apprendre les formules ! Faut pas exagérer non plus... De toute manière il faut des neurones pour apprendre pareille barbarie et je suis en rupture de stock là...

Il n'en reste pas moins que la petite Aline ...ne rêve que de macro ...

Le 04/05/2015 à 13:39

Bonjour messieurs,

Je vous remercie infiniement pour les réponses proposées.

Oui, je savais que c'était possible par formules mais dans la demande, c'est que tout soit réalisé by one click.

Alors je me perds dans les méandres du vba. J'avais commencé à regrouper des données mais je n'aurais jamais atteint un tel résultat.

Merci à vous

Le 05/05/2015 à 10:35

Bonjour,

Les seules différences entre une macro et les formules ... sont que ...

1. Tu n'as pas besoin de "one click" ...

et

2. Au fur et à mesure que les données de base changent, les formules s'ajustent automatiquement toutes seules ...

Le 05/05/2015 à 10:40

Coucou James,

Si je demande cela par macro c'est qu'elle fera partie d'un tout et de l'automatisation d'un fichier dont vous avez eu un tres faible aperçu avec mon fichier d'exemple.

Et crois moi, j'aurais préféré l'utilisation de formules mais ca aurait fait beaucoup trop de manutention

Mais merci de ton implication et de ton suivi.

Transition toute trouvée car :

Je reviens vers vous concernant la macro.

Elle fonctionne merveilleusement bien et même trop en fait ^^

C'est de ma faute, car je n'avais pas envisagé ce cas dans mes réflexions mais l'exemple est pourtant présent dans le fichier que je vous avais envoyé.

Je vous explique :

En feuille "Test", le titre XS0856124 est présent à la fois dans les "Ptf" KAVI et KRD

Mais lorsque la macro tourne, le titre XS0856124 est entièrement regroupé en une ligne (ce qui est normal car c'était ma demande )

Je souhaiterais, maintenir la dichotomie des "Ptf" dans la restitution. Cela est-il possible ?

Merci d'avance

Le 05/05/2015 à 11:40

Re,

Thauthème va être ravi d'apprendre ... ton nouveau besoin ...

A vrai dire, tu es en train de répliquer le principe du tableau croisé dynamique ...

Voilà un joli défi de programmation ... surtout s'il faut le rendre modulaire et générique ...

Le 05/05/2015 à 11:59

Bonjour Aline, bonjour le forum,

Le code modifié (encore plus tordu mais semble toujours fonctionner) :

Sub Macro1()
Dim T As Worksheet 'déclare la variable T (onglet TEST)
Dim F As Worksheet 'déclare la variable F (onglet Feuil2)
Dim TC As Variant 'déclare la variable TC (Tableau de Cellules)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim I As Integer 'déclare la variable I (Incrément)
Dim TMP1 As Variant 'déclare la variable TMP1 (tableau TeMPoraire1)
Dim TMP2 As Variant 'déclare la variable TMP2 (tableau TeMPoraire2)
Dim K As Integer 'déclare la variable K (incrément)
Dim PT As String 'déclare la variable PT (Ptf + Titre)
Dim N As Integer 'déclare la variable N (incrément)
Dim TL() As Variant 'déclare la variable TL (Tableau de Lignes)
Dim NO As Integer 'déclare la variable NO (Nombre d'Occurrences)
Dim J As Byte 'déclare la variable J (incrément)
Dim L As Integer 'déclare la variable L (incrément)
Dim M As Integer 'déclare la variable M (incrément)

Set T = Sheets("Test") 'définit l'onglet T
Set F = Sheets("Feuil2") 'définit l'onglet F
F.Range("A1").CurrentRegion.ClearContents 'efface d'éventuelles anciennes données
TC = T.Range("A1").CurrentRegion 'définit la tableau de cellules TC
Set D = CreateObject("Scripting.dictionary")
For I = 2 To UBound(TC) 'boucle 1 : sur toutes les lignes I du tableau TC (en partant de la seconde)
    D(TC(I, 1) & "-" & TC(I, 4)) = D(TC(I, 1) & "-" & TC(I, 4)) + 1 'alimente le dictionnaire avec le (Ptf-Titre)
Next I 'prochain élément de la boucle1
TMP1 = D.Keys 'récupère dans le tableau temporaire TMP1 les éléments du dictionnaire D sans doublon
TMP2 = D.Items 'pour chaque élément de TMP1 récupère dans le tableau temporaire TMP2 le nombre d'occurrences de l'élément
K = 1 'initialise la variable K
For I = 2 To UBound(TC, 1) 'boucle 2 : sur toutes les lignes I du tableau TC (en partant de la seconde)
    PT = TC(I, 1) & "-" & TC(I, 4) 'définit la variable PT (Ptf-Titre)
    For N = 0 To UBound(TMP1, 1) 'boucle 3 : sur tous les éléments du tableau temporaire TMP1
        If TMP1(N) = PT Then NO = TMP2(N): Exit For 'définit le nombre d'occurrences NO de l'élément correspondant à PT, sort de la boucle
    Next N 'prochain élément de la boucle 3
    'redimensionne le tableau de lignes TL (autant de lignes que TC a de colonnes, K colonnes)
    ReDim Preserve TL(1 To UBound(TC, 2), 1 To K)
    If NO = 1 Then 'condition 1 : si il n'y a qu'une seule occurrence de TC(I,4) dans la colonne 4
        For J = 1 To UBound(TC, 2) 'boucle 4 : sur toutes les colonnes J de TC
            TL(J, K) = TC(I, J) 'récupère dans la ligne de TL la valeur de la colonne de TC (transposition)
        Next J 'prochaine colonne de la boucle 4
    Else 'sinon (condition 1 : si plusieurs occurrences de TC dans la colonne 4 de l'onglet T)
        For M = 1 To UBound(TL, 2) 'boucle 5 sur toutes les colonnes M de TL
            'si la valeur ligne I colonne 4 de TC est égale à la valeur ligne 4 colonne M de TL, va à l'étiquette "suite"
            If PT = TL(1, M) & "-" & TL(4, M) Then GoTo suite
        Next M 'prochaine colonne de la boucle 5
        For J = 1 To UBound(TC, 2) 'boucle 6 : sur toutes les colonnes J de TC
            TL(J, K) = TC(I, J) 'récupère dans la ligne de TL la valeur de la colonne de TC (transposition)
        Next J 'prochaine colonne de la boucle 6
        For L = 2 To UBound(TC, 1) 'boucle 7 sur toutes les lignes L du tableau de cellules TC (en partant de la seconde
            'condition 2 : si la valeur de la boucle 1 est égale à la valeur de la boucle 6 avec I diférent de L
            If PT = TC(L, 1) & "-" & TC(L, 4) And I <> L Then
                TL(5, K) = TL(5, K) + TC(L, 5) 'ajoute les VB
                TL(6, K) = TL(6, K) + TC(L, 6) 'ajoute les ASD
                TL(7, K) = TL(7, K) + TC(L, 7) 'ajoute les SD
                TL(8, K) = TL(8, K) + TC(L, 8) 'ajoute les PDD
            End If 'fin de la condition 2
        Next L 'prochaine ligne de la boucle 7
    End If 'fin de la condition 1
    K = K + 1 'incrément K (rajoute une colonne à TL
suite:     'étiquette
Next I 'prochaine ligne de la boucle 2
'renvoie dans la cellule A1 (redimensionnée) de l'onglet F, le tanleau TL transposé
F.Range("A1").Resize(UBound(TL, 2), UBound(TL, 1)).Value = Application.Transpose(TL)
F.Range("E2:H" & F.Cells(Application.Rows.Count, 1).End(xlUp).Row).NumberFormat = _
   "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)" 'format de la plage des valeurs
End Sub

J'm'en fous James... je rajoute des boucles....

Le 05/05/2015 à 16:14

Merci à toi,

C'est exactement ce que je souhaitais.

Je suis vraiment impressionnée par le code. J'ai essayé de le comprendre mais y a certains éléments qui m'échappent complètement.

A très bientôt

Rechercher des sujets similaires à "macro agreger lignes valeur ident"