Discussion :

[Ptitbubu75]

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 !!!

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
 
 
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

[EricDgn]

Bonjour,

Quelque chose de ce genre, uniquement utilisable après un tri sur les colonnes D et G (et en supposant qu'il n'y a rien en dessous du tableau commençant en A1:G1).

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
Option Explicit
 
Sub GererDoublons()
    Dim lastRow As Long, i As Long, j As Long, doublon As Boolean, n As Long
 
    Trier                                               '--- sans tri, doublons non gérés
    lastRow = Cells(Rows.Count, "A").End(xlUp).Row      '--- dernière ligne utilisée dans la colonne A
    doublon = False
 
    For i = lastRow To 2 Step -1                        '--- aller du bas vers le haut
        If Cells(i, "D") = 9 Then
            '--- passer
        ElseIf Cells(i, "D") = 0 Then
            '--- passer
        ElseIf Cells(i - 1, "D") <> Cells(i, "D") Then
            '--- passer
        ElseIf Cells(i - 1, "G") <> Cells(i, "G") Then
            '--- passer
        Else
            doublon = True
        End If
        If doublon Then
            n = n + 1
        Else
            If n > 0 Then
                j = i + n + 1
                Rows(j).Insert xlDown
                Cells(j, 1) = Cells(i, 1)
                Cells(j, 4) = Cells(i, 4)
                Cells(j, 5) = Cells(i, 5)
                Cells(j, 7) = Cells(i, 7)
                Cells(j, 6) = Application.Sum(Range(Cells(i, 6), Cells(j - 1, 6)))
                With Range("A" & j & ":G" & j)
                    .Font.Bold = True
                    With .Interior
                        .Pattern = xlSolid
                        .PatternColorIndex = xlAutomatic
                        .ThemeColor = xlThemeColorDark2
                        .TintAndShade = 0
                        .PatternTintAndShade = 0
                    End With
                End With
            End If
            n = 0
        End If
        doublon = False
    Next i
    Range("A1").Select
End Sub
 
Sub Trier()
    With ActiveSheet.Sort
        .SortFields.Clear
        .SortFields.Add2 key:=Range("D:D")
        .SortFields.Add2 key:=Range("G:G")
        .SetRange Range("A:G")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Cordialement.