Regrouper des lignes et additionner une cellule

Bonjour à tous,

Je viens vers vous car j'aurai besoin d'aide pour créer une macro. Je suis novice dans ce domaine

Mon but serait de regrouper les lignes qui sont identiques (en vérifiant que les données des colonnes soient identiques - sauf pour la colonne Q) et de les faire se regrouper en 1 seule ligne quand elles sont identiques tout en additionnant les données de la colonne Z (que j'ai mise en bleu dans le fichier attaché [toutes les informations sont fictives mais j'ai conservé les colonnes comme j'en ai besoin]).

Je sais que j'ai qq lignes à regrouper par exemple:

- lignes 6-7-8

- lignes 13-14

A noter que mon fichier original comporte environ 60 000 lignes, et que jusqu'à présent j'utilisais un tableau croisé dynamique.

Mais j'aimerai avoir le fichier mis à jour car je souhaite l'utiliser aussi à d'autres fins.

En vous remerciant par avance pour votre aide!

Bonjour,

une solution "iconoclaste" : faire un TCD

Merci Steelson, comme je disais c'est ce que je faisais jusqu'à maintenant mais j'ai besoin de pouvoir utiliser mon fichier pour d'autres choses d'où ma question car ces doublons de lignes ne sont pas compatibles

Autre solution : faire une macro ... je regarde !

Salut Pachi,
Salut Steelson

sauf pour la colonne Q

Que fait-on de ces valeurs différentes : concaténation

A+

Merci à tous les 2!

Pardon effectivement j'ai oublié ce petit détail: pour les valeurs de la colonne Q on peut ne garder que celle de la 1ère ligne de doublon

J'ai mis le résultat en feuille2 pour comparer

en Q j'ai mis "multi" le cas échéant

Sub regrouper()

    Sheets(1).Select
    derL = Cells(Rows.Count, 1).End(xlUp).Row

' tri
    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add Key:=Range("A2"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveSheet.Sort
        .SetRange Range("A2:AB" & derL)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

' regroupement
    TBL = Range("A2:AB" & derL)
    For i = LBound(TBL) + 1 To UBound(TBL)
        For j = LBound(TBL, 2) To UBound(TBL, 2)
            ok = True
            If j <> 26 And j <> 17 Then
                If TBL(i, j) <> TBL(i - 1, j) Then ok = False: Exit For
            End If
        Next
        If ok Then
            TBL(i, 26) = TBL(i - 1, 26) + TBL(i, 26)
            For j = LBound(TBL, 2) To UBound(TBL, 2)
                TBL(i - 1, j) = ""
                TBL(i, 17) = "multi"
            Next
        End If
    Next

    Sheets(2).Select
    Cells(2, 1).Resize(UBound(TBL), UBound(TBL, 2)) = TBL

' tri
    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add Key:=Range("A2"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveSheet.Sort
        .SetRange Range("A2:AB" & derL)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Un grand merci pour ton aide Steelson ++++

C'est exactement ce dont j'avais besoin!

Très bonne soirée

Salut Pachi,
Salut Steelson,

ralenti par de gros problèmes de canalisations bouchées, je m'invite dans ton (très) beau salon , sachant que tu n'y verras pas une intrusion, comme d'autres...
Certains "conforts" valent plus chers que les plus beaux codes...

Un double-clic démarre la macro avec extraction en feuille 'Extract'...

For x = 2 To UBound(tTab, 1)
    If tTab(x, 1) <> "" Then
        iIdx = iIdx + IIf(x > 2, 1, 2)
        ReDim Preserve tExtract(UBound(tTab, 2), iIdx)
        If lgNum <> CLng(tTab(x, 1)) Then _
            lgNum = CLng(tTab(x, 1)): _
            lgRow = Columns(1).Find(what:=lgNum, lookat:=xlWhole, LookIn:=xlValues, searchdirection:=xlPrevious).Row
        If x < lgRow Then
            For y = x + 1 To lgRow
                iOK = 0
                For Z = 2 To UBound(tTab, 2)
                    If tTab(y, Z) <> tTab(x, Z) And (Z <> 17 And Z <> 26) Then _
                        iOK = 1: _
                        Exit For
                Next
                If iOK = 0 Then _
                    tTab(y, 1) = "": _
                    tTab(x, 26) = CDbl(tTab(x, 26)) + CDbl(tTab(y, 26))
            Next
        End If
        For y = 1 To UBound(tTab, 2)
            If x = 2 Then tExtract(y - 1, 0) = tTab(1, y)
            tExtract(y - 1, iIdx - 1) = tTab(x, y)
        Next
    End If
Next

A+

Avec plaisir, tout le monde est le bienvenu dans le salon

Merci à toi aussi pour cette macro!

Prochaine étape pour moi, comprendre ça fonctionne grace à ce site pour savoir utiliser VBA par la suite

Bon courage avec tes canalisations