Sommer les valeurs de cellules si valeurs en en double dans une autre

Bonjour,

Je voudrais faire une macro pour réaliser le besoin suivant :

J’ai un tableau avec possiblement plusieurs centaines de ligne, et pas classer.

Colonne A : désignation

Colonne B : fabricant

Colonne C : référence

Colonne D : Numéro CAS

Colonne E : état physique

Colonne F : Quantité

Colonne G : Unité

Si deux valeurs ou plus dans la colonne D sont identiques sauf si ces valeurs sont 0 ou 9, et que pour ces valeurs en doublon les valeurs dans la colonne G sont identiques, alors créer une nouvelle ligne sous les doublons, la mettre en gras copier les informations des doublons des colonnes A, D, E, G et dans la colonne F faire la somme des colonnes F en doublons.

Exemple :

- Ligne 11 et 12, Les cellules D11 et D12 sont identiques et les cellules G11 et G12 sont identiques

Donc je crée la ligne 13 (en gras), je copie les cellules A11 en A13, D11 en D13, E11 en D13, G11 en G13.

Je fais la somme de cellules F11 et F12 que je mets en F13

- Lignes 71 et 72, les cellules D71 et D72 sont identiques et les cellules G71 et G72 sont différentes

Donc je ne fais rien.

- dans mon exemple je n'ai que 2 lignes identiques, il peux y en avoir plus.

L'onglet actif est l'onglet "Produits"

Je essaye le code suivant (grâce à l'AI aussi) mais lors de l'exécution le fichier se ferme !!!

Sub GererDoublons()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim newRow As Long
    Dim dict As Object
    Dim key As String
    Dim doublons As Collection

    ' Définir la feuille de calcul active
    Set ws = ActiveSheet

    ' Trouver la dernière ligne utilisée dans la colonne A
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    ' Initialiser un dictionnaire pour stocker les doublons
    Set dict = CreateObject("Scripting.Dictionary")

    ' Parcourir les lignes du tableau
    For i = 2 To lastRow
        ' Vérifier que la valeur de la colonne D n'est pas 9 ou 0
        If ws.Cells(i, "D").Value <> 9 And ws.Cells(i, "D").Value <> 0 Then
            ' Créer une clé basée sur Colonne D et Colonne G
            key = ws.Cells(i, "D").Value & "_" & ws.Cells(i, "G").Value

            ' Vérifier si la clé existe déjà
            If dict.exists(key) Then
                dict(key).Add i
            Else
                Set doublons = New Collection
                doublons.Add i
                dict.Add key, doublons
            End If
        End If
    Next i

    ' Traiter les doublons trouvés
    For Each key In dict.Keys
        If dict(key).Count > 1 Then
            ' Insérer une nouvelle ligne sous les doublons
            newRow = dict(key).Item(dict(key).Count) + 1
            ws.Rows(newRow).Insert Shift:=xlDown

            ' Copier les informations des doublons
            ws.Cells(newRow, "A").Value = ws.Cells(dict(key).Item(1), "A").Value
            ws.Cells(newRow, "D").Value = ws.Cells(dict(key).Item(1), "D").Value
            ws.Cells(newRow, "E").Value = ws.Cells(dict(key).Item(1), "E").Value
            ws.Cells(newRow, "G").Value = ws.Cells(dict(key).Item(1), "G").Value

            ' Calculer la somme des valeurs en colonne F
            Dim somme As Double
            somme = 0
            For Each i In dict(key)
                somme = somme + ws.Cells(i, "F").Value
            Next i
            ws.Cells(newRow, "F").Value = somme

            ' Mettre la nouvelle ligne en gras
            ws.Rows(newRow).Font.Bold = True
        End If
    Next key

End Sub

Merci pour votre aide.

Salut PtitBubu,

Quelque chose ainsi ?

Sub GererDoublons()
'
Dim tTab, iRow%, iIdx%
'
Application.EnableEvents = False
Application.ScreenUpdating = False
'
With Worksheets("Produits")
    iRow = .Range("A" & Rows.Count).End(xlUp).Row
    .Range("A2:G" & iRow).Sort _
        key1:=.Range("D2"), order1:=xlAscending, _
        key2:=.Range("G2"), order2:=xlAscending, _
        Orientation:=xlTopToBottom, Header:=xlNo
    tTab = .Range("A1:H" & iRow + 1).Value
    For x = 1 To 2
        For y = iRow To 2 Step -1
            If x = 1 Then
                If tTab(y, 4) <> 0 And tTab(y, 4) <> 9 Then _
                    If tTab(y - 1, 4) = tTab(y, 4) And tTab(y, 7) = tTab(y - 1, 7) Then _
                        tTab(y, 8) = tTab(y + 1, 8) + 1: _
                        tTab(y - 1, 8) = tTab(y, 8) + 1
            Else
                If tTab(y, 8) > 0 Then
                    If tTab(y, 8) = 1 Then _
                        iIdx = y + 1: _
                        .Rows(iIdx).EntireRow.Insert shift:=xlDown: _
                        .Cells(iIdx, 1).Resize(1, 7).Font.Bold = True: _
                        .Cells(iIdx, 1).Resize(1, 7).Borders(xlEdgeBottom).LineStyle = xlContinuous: _
                        .Cells(iIdx, 1) = tTab(y, 1): _
                        .Cells(iIdx, 4) = tTab(y, 4): _
                        .Cells(iIdx, 5) = tTab(y, 5): _
                        .Cells(iIdx, 7) = tTab(y, 7)
                    .Cells(iIdx, 6) = .Cells(iIdx, 6) + tTab(y, 6)
                End If
            End If
        Next
    Next
End With
Erase tTab
'
Application.ScreenUpdating = True
Application.EnableEvents = True
'
End Sub

A+

Merci pour ton retour.

Quand je lance la macro il m'indique une erreur : tTab(y, 8) = tTab(y + 1, 8) + 1: _

Salut Ptitbubu,

sur mon fichier ou sur celui sur lequel tu as transféré la macro?
Dans ce dernier cas, prière de m'envoyer un fichier ayant la même structure que ton fichier de travail.

A+

Sur les deux

Je t'envoie mon fichier, qui n'a rien de confidentiel

Salut PtitBubu,

le problème venait du fait que, comme très souvent, j'ai dû démarrer sans connaître la structure du fichier de travail!
Je ne savais donc pas qu'il y avait une colonne [H:H] avec des données!

Donc, prochaine demande :

En l'état, tu te rends bien compte que cette macro ne fonctionnera valablement qu'UNE seule fois!
Si tu es amené à faire cette manip' régulièrement sur cette feuille 'Produits', il faudra apporter quelques modif' à la macro! OK ?

A+

Oui j'en suis conscient, je l'utiliserais mais à chaque fois avec un onglet "Produits" différents mais de même structure, seul le nombre de ligne changera.

Merci .

SalutPtitBubu,

pour la même raison d'absence de fichier original, il doit y avoir une erreur dans cette ligne qu'il faut corriger ainsi...

                    .Cells(iIdx, 6) = .Cells(iIdx, 6) + tTab(y, 7)

...tTab(y,7) contenant la valeur en colonne [G:G].

A+