| 12
 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
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
 100
 101
 102
 103
 104
 105
 106
 107
 108
 109
 110
 111
 112
 113
 114
 115
 116
 117
 118
 119
 120
 121
 122
 123
 124
 125
 126
 127
 128
 129
 130
 131
 132
 133
 134
 135
 136
 137
 138
 139
 140
 141
 
 | Sub doublon()
'sous procédure de vérification des doublons
'masquer les actions de la macro
Application.ScreenUpdating = False
derlgn = Workbooks(classeuract).Sheets(1).Cells(Workbooks(classeuract).Sheets(1).Columns(1).Cells.Count, 1).End(xlUp).Row
'numéroter les lignes de facon à pouvoir les remettre dans le bon ordre à la fin
For m = 6 To derlgn
    Workbooks(classeuract).Sheets(1).Cells(m, 22) = m - 5
Next m
 
'trier la plage pour regrouper les doublons
    Workbooks(classeuract).Sheets(1).Sort.SortFields.Clear
    Workbooks(classeuract).Sheets(1).Sort.SortFields.Add Key:=Range("B6:B" & derlgn), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
    Workbooks(classeuract).Sheets(1).Sort.SortFields.Add Key:=Range("D6:D" & derlgn), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
    Workbooks(classeuract).Sheets(1).Sort.SortFields.Add Key:=Range("E6:E" & derlgn), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
    Workbooks(classeuract).Sheets(1).Sort.SortFields.Add Key:=Range("H6:H" & derlgn), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
    Workbooks(classeuract).Sheets(1).Sort.SortFields.Add Key:=Range("I6:I" & derlgn), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
    Workbooks(classeuract).Sheets(1).Sort.SortFields.Add Key:=Range("K6:K" & derlgn), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
    Workbooks(classeuract).Sheets(1).Sort.SortFields.Add Key:=Range("P6:P" & derlgn), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
    Workbooks(classeuract).Sheets(1).Sort.SortFields.Add Key:=Range("Q6:Q" & derlgn), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
 
    With Workbooks(classeuract).Sheets(1).Sort
        .SetRange Range("A5:V" & derlgn)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 
'on part du bas pour éviter ls problemes quand on suprime la ligne ne cours
For m = derlgn To 6 Step -1
    'si le pn fournisseur est le même sur la ligne m et la ligne m-1, alors
    If Workbooks(classeuract).Sheets(1).Cells(m, 2) = Workbooks(classeuract).Sheets(1).Cells(m - 1, 2) Then
        'vérifier si tout les champs significatif sont identiques, si oui, effacer la ligne
        If Workbooks(classeuract).Sheets(1).Cells(m, 2) & Workbooks(classeuract).Sheets(1).Cells(m, 4) & Workbooks(classeuract).Sheets(1).Cells(m, 5) & Workbooks(classeuract).Sheets(1).Cells(m, 8) & Workbooks(classeuract).Sheets(1).Cells(m, 9) & Workbooks(classeuract).Sheets(1).Cells(m, 11) & Workbooks(classeuract).Sheets(1).Cells(m, 16) & Workbooks(classeuract).Sheets(1).Cells(m, 17) = Workbooks(classeuract).Sheets(1).Cells(m - 1, 2) & Workbooks(classeuract).Sheets(1).Cells(m - 1, 4) & Workbooks(classeuract).Sheets(1).Cells(m - 1, 5) & Workbooks(classeuract).Sheets(1).Cells(m - 1, 8) & Workbooks(classeuract).Sheets(1).Cells(m - 1, 9) & Workbooks(classeuract).Sheets(1).Cells(m - 1, 11) & Workbooks(classeuract).Sheets(1).Cells(m - 1, 16) & Workbooks(classeuract).Sheets(1).Cells(m - 1, 17) Then
            Workbooks(classeuract).Sheets(1).Rows(m & ":" & m).Delete
        End If
    End If
 
    'si le pn fournisseur est le même sur la ligne m et la ligne m-1, alors
    If Workbooks(classeuract).Sheets(1).Cells(m, 2) = Workbooks(classeuract).Sheets(1).Cells(m - 1, 2) Then
        'vérifier si la seconde ligne est incomplete et que la premiere est complete, alors
        'effacer la seconde
        'normalement, à cause du tri, ca sera toujours dans ce sens la, les vides étant trié
        'apres les pleins
        If (Replace(Workbooks(classeuract).Sheets(1).Cells(m, 18), "Nom trop long", "") <> "") And (Replace(Workbooks(classeuract).Sheets(1).Cells(m - 1, 18), "Nom trop long", "") = "") Then
            Workbooks(classeuract).Sheets(1).Rows(m & ":" & m).Delete
        End If
    End If
 
    'si le pn fournisseur est le même sur la ligne m et la ligne m-1, alors
    If Workbooks(classeuract).Sheets(1).Cells(m, 2) = Workbooks(classeuract).Sheets(1).Cells(m - 1, 2) Then
        'traiter les doublons quand les deux sont complets ou tout les deux sont incomplets avec
        'des différences entres les deux lignes
            'si la différence est au niveau du prix d'achat
            If Workbooks(classeuract).Sheets(1).Cells(m, 4) <> Workbooks(classeuract).Sheets(1).Cells(m - 1, 4) Then
                k = m
                Excel.Run ("retourchariot")
                Workbooks(classeuract).Sheets(1).Cells(m, 18) = Workbooks(classeuract).Sheets(1).Cells(m, 18) & "doublon différence prix d'achat"
                k = m - 1
                Excel.Run ("retourchariot")
                Workbooks(classeuract).Sheets(1).Cells(m - 1, 18) = Workbooks(classeuract).Sheets(1).Cells(m - 1, 18) & "doublon différence prix d'achat"
            End If
            'si la différence est au niveau du prix de vente
            If Workbooks(classeuract).Sheets(1).Cells(m, 5) <> Workbooks(classeuract).Sheets(1).Cells(m - 1, 5) Then
                k = m
                Excel.Run ("retourchariot")
                Workbooks(classeuract).Sheets(1).Cells(m, 18) = Workbooks(classeuract).Sheets(1).Cells(m, 18) & "doublon différence prix de vente"
                k = m - 1
                Excel.Run ("retourchariot")
                Workbooks(classeuract).Sheets(1).Cells(m - 1, 18) = Workbooks(classeuract).Sheets(1).Cells(m - 1, 18) & "doublon différence prix de vente"
            End If
            'si la différence est au niveau de la famille
            If Workbooks(classeuract).Sheets(1).Cells(m, 8) <> Workbooks(classeuract).Sheets(1).Cells(m - 1, 8) Then
                k = m
                Excel.Run ("retourchariot")
                Workbooks(classeuract).Sheets(1).Cells(m, 18) = Workbooks(classeuract).Sheets(1).Cells(m, 18) & "doublon différence famille"
                k = m - 1
                Excel.Run ("retourchariot")
                Workbooks(classeuract).Sheets(1).Cells(m - 1, 18) = Workbooks(classeuract).Sheets(1).Cells(m - 1, 18) & "doublon différence famille"
            End If
            'si la différence est au niveau de la sous famille
            If Workbooks(classeuract).Sheets(1).Cells(m, 9) <> Workbooks(classeuract).Sheets(1).Cells(m - 1, 9) Then
                k = m
                Excel.Run ("retourchariot")
                Workbooks(classeuract).Sheets(1).Cells(m, 18) = Workbooks(classeuract).Sheets(1).Cells(m, 18) & "doublon différence sous-famille"
                k = m - 1
                Excel.Run ("retourchariot")
                Workbooks(classeuract).Sheets(1).Cells(m - 1, 18) = Workbooks(classeuract).Sheets(1).Cells(m - 1, 18) & "doublon différence sous-famille"
            End If
            'si la différence est au niveau du type (récupel ou non)
            If Workbooks(classeuract).Sheets(1).Cells(m, 11) <> Workbooks(classeuract).Sheets(1).Cells(m - 1, 11) Then
                k = m
                Excel.Run ("retourchariot")
                Workbooks(classeuract).Sheets(1).Cells(m, 18) = Workbooks(classeuract).Sheets(1).Cells(m, 18) & "doublon différence type (récupel)"
                k = m - 1
                Excel.Run ("retourchariot")
                Workbooks(classeuract).Sheets(1).Cells(m - 1, 18) = Workbooks(classeuract).Sheets(1).Cells(m - 1, 18) & "doublon différence type (récupel)"
            End If
            'si la différence est au niveau de la quantité minimum
            If Workbooks(classeuract).Sheets(1).Cells(m, 16) <> Workbooks(classeuract).Sheets(1).Cells(m - 1, 16) Then
                k = m
                Excel.Run ("retourchariot")
                Workbooks(classeuract).Sheets(1).Cells(m, 18) = Workbooks(classeuract).Sheets(1).Cells(m, 18) & "doublon différence Qté min"
                k = m - 1
                Excel.Run ("retourchariot")
                Workbooks(classeuract).Sheets(1).Cells(m - 1, 18) = Workbooks(classeuract).Sheets(1).Cells(m - 1, 18) & "doublon différence Qté min"
            End If
            'si la différence est au niveau de la devis d'achat
            If Workbooks(classeuract).Sheets(1).Cells(m, 17) <> Workbooks(classeuract).Sheets(1).Cells(m - 1, 17) Then
                k = m
                Excel.Run ("retourchariot")
                Workbooks(classeuract).Sheets(1).Cells(m, 18) = Workbooks(classeuract).Sheets(1).Cells(m, 18) & "doublon différence devise achat"
                k = m - 1
                Excel.Run ("retourchariot")
                Workbooks(classeuract).Sheets(1).Cells(m - 1, 18) = Workbooks(classeuract).Sheets(1).Cells(m - 1, 18) & "doublon différence devise achat"
            End If
    End If
Next m
 
'je remet un derlgn pour le réactualiser apres la supression des doublons
derlgn = Workbooks(classeuract).Sheets(1).Cells(Workbooks(classeuract).Sheets(1).Columns(1).Cells.Count, 1).End(xlUp).Row
 
'remettre les informations dans l'ordre en utilisant la colonne V qu'on a numéroté en début de procédure
Workbooks(classeuract).Sheets(1).Sort.SortFields.Clear
Workbooks(classeuract).Sheets(1).Sort.SortFields.Add Key:=Range("V6:V" & derlgn), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
 
With Workbooks(classeuract).Sheets(1).Sort
    .SetRange Range("A5:V" & derlgn)
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
 
Workbooks(classeuract).Sheets(1).Columns("V:V").Delete
 
Application.ScreenUpdating = True
End Sub | 
Partager