Macro complémentaire supprimer les doublons sous conditions

Le 18/05/2016 à 15:32

Bonjour,

J'ai besoin de vos compétences pour terminer ma macro automatique. J'ai des extractions de données de notre GPAO vers Excel que je veux mettre en forme pour une lecture plus "digeste". par les opérateurs. J'ai fait une macro complémentaire avec un bouton sur le ruban qui sera accessible de tous les PC de l'entreprise. J'ai réussi à faire la mise en forme qui va bien, pagination, en-tête, marges....mais je veux aussi supprimer les doublons de la colonne A uniquement si les données de la colonne B sont à 0 et c'est là que le bât blesse...j'ai essayé les filtres avancés, supprimer les doublons avec critères, je ne trouve rien qui me convienne sur les forums.

Je vous joins un fichier que j'ai tronqué. Ma macro n'y est pas, comme elle est enregistrée dans un classeur perso en.xlsb, c'est normal.

Merci d'avance pour votre disponibilité.

38extract.zip (9.97 Ko)
Le 18/05/2016 à 16:22

Bonjour Mano, bonjour le forum,

Il doit y avoir beaucoup, beaucoup plus simple mais le code ci-dessous semble fonctionner :

Sub Macro1()
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim TT As Variant 'déclare la variable TT (Tableau Temporaire)
Dim TL() As Variant 'déclare la variable TL (Tableau des lignes)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set O = Sheets("Export17") 'définit l'onglet O
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
TV = O.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
For I = 2 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV (en parant de la secodne)
    D(TV(I, 1)) = "" 'alimente le dictionnaire D avec les données de la colonne "OF"
Next I 'prochaine ligne de la boucle
TT = D.keys 'récupère dans le tableau temporaire TT la liste ds éléments du dictionaire D sans doublon
For J = 0 To UBound(TT) 'boucle 1 : sur tous les élément du tableau temporaire TT
    For I = 2 To UBound(TV, 1) 'boucle 2 : sur toutes les lignes I du tableau des valeurs TV (en parant de la secodne)
        If TV(I, 1) = TT(J) And TV(I, 2) = 0 Then 'condition si la donneée ligne I, colonne 1 de TV correspond à l'élément J du tableau TT et si la données ligne I, colonne 2 de TV vaut zéro
            ReDim Preserve TL(K) 'redimensionne le tableau TL
            TL(K) = I 'récupère le numéro de ligne
            K = K + 1 'incrémente K
        End If 'fin de la condition
    Next I 'prochaine ligne de la boucle 2
Next J 'prochain élément de la boucle 1
Debug.Print UBound(TL, 1)
For I = UBound(TL) To 0 Step -1 'boucle inversée sur tous les éléments du tableau des lignes TL
    O.Rows(TL(I)).Delete 'supprime la ligne de l'élément I du tableau des lignes TL
Next I 'prochain élément de la boucle
Application.ScreenUpdating = True 'affiche les rafraîchissement d'écran
End Sub
Le 18/05/2016 à 17:19

Bonjour ThauThème et merci pour ton retour rapide

Cela marche bien mais je me suis mal exprimée. Je voudrais avoir tous les OF de la colonne A mais 1 seule fois lorsque j'ai une donnée à 0 dans la colonne B et lorsque j'ai une donnée à 1 dans la colonne B, là il me faut toutes les lignes de l'OF.

J'espère que tu comprends mon charabia...

Le 18/05/2016 à 21:11

Re,

Alors si j'ai mieux compris, essaie ce code :

Sub Macro1()
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim K As Integer 'déclare la variable K (incrément)
Dim TT As Variant 'déclare la variable TT (Tableau Temporaire)
Dim TL() As Variant 'déclare la variable TL (Tableau des lignes)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set O = Sheets("Export17") 'définit l'onglet O
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
TV = O.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
For I = 2 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV (en parant de la seconde)
   D(TV(I, 1)) = "" 'alimente le dictionnaire D avec les données de la colonne "OF"
Next I 'prochaine ligne de la boucle
TT = D.keys 'récupère dans le tableau temporaire TT la liste ds éléments du dictionaire D sans doublon
For J = 0 To UBound(TT) 'boucle 1 : sur tous les élément du tableau temporaire TT
    For I = 2 To UBound(TV, 1) 'boucle 2 : sur toutes les lignes I du tableau des valeurs TV (en parant de la seconde)
        If TV(I, 1) = TT(J) And TV(I, 2) = 0 Then 'condition si la donneée ligne I, colonne 1 de TV correspond à l'élément J du tableau TT et si la données ligne I, colonne 2 de TV vaut zéro
            ReDim Preserve TL(K) 'redimensionne le tableau TL
            TL(K) = I 'récupère le numéro de ligne
            K = K + 1 'incrémente K
        End If 'fin de la condition
    Next I 'prochaine ligne de la boucle 2
    ReDim Preserve TL(K - 2) 'redimensionne le tableau TL (supprime la dernière valeur)
    K = K - 1 'décrémente K
Next J 'prochain élément de la boucle 1
For I = UBound(TL) To 0 Step -1 'boucle inversée sur tous les éléments du tableau des lignes TL
    O.Rows(TL(I)).Delete 'supprime la ligne de l'élément I du tableau des lignes TL
Next I 'prochain élément de la boucle
Application.ScreenUpdating = True 'affiche les rafraîchissement d'écran
End Sub
Le 19/05/2016 à 10:58

Bonjour,

Tu as bien compris merci encore. J'ai rajouté le code à ma macro complémentaire et ça fonctionne très bien. J'ai simplement remplacé la variable "SET O" ("Extrat17" par "ActiveSheet") car lorsque les données GPAO/EXCEL sont extraites, l'onglet se renomme à chaque fois. Si tu peux encore faire quelque chose pour moi, sans vouloir abuser de ton temps, lorsque j'ai des OF avec ruptures à 1 je n'ai pas besoin de la ligne du même OF avec ruptures à 0 (24669 & 23702 dans mon tableau).

Bonne journée

Le 21/05/2016 à 23:22

Bonsoir Mano, bonsoir le forum,

Après pas mal d'infructueuses recherches, je pense avoir trouvé le code qui convient :

Sub Macro1()
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim PL As Range 'déclare la variable PL (PLage)
Dim CEL As Range 'déclare la variable CEL (CELlule)
Dim TT As Variant 'déclare la variable TT (Tableau Temporaire)
Dim PLV As Range 'déclare la variable PLV (PLage Visible)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set O = ActiveSheet 'définit l'onglet O
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
Set PL = O.Range("A1").CurrentRegion 'définit la plage PL
Set PL = PL.Offset(1, 0).Resize(PL.Rows.Count - 1, PL.Columns.Count) 'redéfinit la plage PL (sans la première ligne)
For Each CEL In Application.Intersect(PL, O.Columns(1)) 'boucle sur toutes les cellules CEL de la première colonne de la plage PL
    D(CEL.Value) = "" 'alimente le dictionnaire D avec les données de la colonne "OF"
Next CEL 'prochaine cellule de la boucle
TT = D.keys 'récupère dans le tableau temporaire TT la liste des éléments du dictionnaire D sans doublon
For I = 0 To UBound(TT) 'boucle sur tous les élément du tableau temporaire TT
    O.Range("A1").AutoFilter Field:=1, Criteria1:=TT(I) 'filtre la colonne OF avec TT(I) comme critère
    Set PLV = PL.SpecialCells(xlCellTypeVisible) 'définit la plage PLV
    'condition : si il y a au moins un "1" dans la colonne Rupture
    If Application.WorksheetFunction.CountIf(Application.Intersect(PLV, O.Columns(2)), 1) > 0 Then
        O.Range("A1").AutoFilter Field:=2, Criteria1:=0 'filtre la colonne rupture avec 0 comme critère
        Set PLV = PL.SpecialCells(xlCellTypeVisible) 'définit la plage PLV
        PLV.EntireRow.Delete 'supprime la plage PLV
    Else 'sinon
        'supprime la plage PLV sans la première ligne
        PLV.Offset(1, 0).Resize(PLV.Rows.Count - 1, PLV.Columns.Count).EntireRow.Delete
    End If 'fin de la conditon
        O.Range("A1").AutoFilter 'supprime le Filtre automatique
Next I 'prochain élément de la boucle
Application.ScreenUpdating = True 'affiche les rafraîchissement d'écran
End Sub
Le 23/05/2016 à 21:10

Bonsoir ThéauThème

Je suis embêtée et embêtante.....Lorsque je teste ton code dans mon fichier, j'ai le message d'erreur "impossible de lire la propriété Countif de la classe worksheetFunction" et la ligne "If Application.WorksheetFunction.CountIf(Application.Intersect(PLV, O.Columns(2)), 1) > 0 Then" surlignée en jaune. Je pense avoir trouvé la cause mais je n'arrive pas à corriger le code. Dans la colonne A de mon tableau, j'ai différents préfixes devant les chiffres ("I" et "OF"), ce qui n'est pas le cas dans le fichier posté, il n'y a que des chiffres avec le préfixe "I". J'ai testé le code avec un seul préfixe et ça marche bien (I ou OF). Sur ton code précédent, je n'avais pas ce soucis, il fonctionnait quelque soit les préfixes des données de la colonne A. Une précision si besoin, je n'aurai jamais les mêmes chiffres derrière "I" et "OF". Je joins le tableau en V2 avec de nouvelles données.

Merci bcpbcp

12extract-2.zip (29.37 Ko)
Rechercher des sujets similaires à "macro complementaire supprimer doublons conditions"