mettre en evidence Doublons et +

[agadiroufla]

Bonjour,
Je bloque un peu dans mon code de recherche des doublons.
Pourriez vous regarder et me dire ce qu'il faut changer.
J ai essayé toutes les configurations mais le résultat n'est pas bon.
(j ai expliqué les conditions dans le module)
Merci bcp.

 

[WUTED]

Re : mettre en evidence Doublons et +

Bonjour agadiroufla, le forum,

J'ai regardé ton code et l'erreur vient d'une de tes boucles For :

Sub repérer_doublons_détachement_posstk()
'Désactive la mise à jour de l'affichage
Application.ScreenUpdating = False
'Désactive la mise à jour des recalculs
Application.Calculation = xlCalculationManual
 Sheets("feuil1").Visible = True
 Sheets("feuil1").Select
 
Dim LastRow As Long
Dim i As Long, j As Long
Dim s1 As Variant, c1 As Double
Dim s2 As Variant, c2 As Double
Dim t1 As Variant, d1 As String
Dim t2 As Variant, d2 As String
i = 2
j = 2
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    Application.ScreenUpdating = False
    Columns("A:H").Interior.ColorIndex = xlNone
    
    For i = 2 To LastRow
     t1 = Range("A" & i).Value 'Code ptf
     c1 = Range("E" & i).Value 'QTE
     d1 = Range("D" & i).Value 'Libéllé
     s1 = Range("C" & i).Value 'ISIN
------------------------------
    For j = i + 1 To LastRow
------------------------------
     t2 = Range("A" & j).Value 'Code ptf
     c2 = Range("E" & j).Value 'QTE
     d2 = Range("D" & j).Value 'Libéllé
     s2 = Range("C" & j).Value 'ISIN
     
    'explication: si pour le même code PTF on retrouve des doublons de code ISIN(rangeC) ou doublons LIBELLE(range D) les mettre en evidence
            If (t1 = t2 And c1 = c2 And Left(s1, 9) = Left(s2, 9)) Or (Left(d1, 9) = Left(d2, 9)) Then
                Range("C" & j).Interior.ColorIndex = 50
                Range("E" & j).Interior.ColorIndex = 50
                Range("A" & j).Interior.ColorIndex = 50
                Range("D" & j).Interior.ColorIndex = 50
            End If
    
    Next j
    Next i
        Application.ScreenUpdating = True
    ' Rétablissement du mode de recalcul d'origine
Application.Calculation = xlAutomatic
End Sub

Comme tu avais mis i et j à la même valeur de départ, chaque ligne se comparait avec elle-même et donc, ça colorait l'ensemble de ta Sheet, j'ai testé et ton module marche bien chez moi avec les modifications sur le For du j.

Bonne aprés-midi,
WUTED

 

[Robert]

Re : mettre en evidence Doublons et +

Bonjour Agadiroufla, bonjour le forum,

En pièce jointe ton fichier modifié avec le code ci-dessous :

Sub Macro1()
Dim dl As Long 'déclare la variable dl (Dernière Ligne)
Dim pl As Range 'déclare la variable pl (PLage)
Dim dico As Object 'déclare la variable dido (DICtiOnnaire)
Dim temp As Variant 'déclare la variable temp (tableau TEMPoraire)
Dim r As Range 'déclare la variable r (Recherche)
Dim pa As String 'déclare la variable pa (Première Adresse)
Dim li As Long 'déclare la variable li (LIgne)

Application.ScreenUpdating = False 'masque les changement à l'écran
Application.Calculation = xlCalculationManual 'calcul manuel
Sheets("feuil1").Visible = True 'affiche l'onglet "Feuil1"

With Sheets("feuil1") 'prend en compte l'onglet "Feuil1"
    dl = .Range("A" & Rows.Count).End(xlUp).Row 'définit la dernière ligne dl
    .Columns("A:H").Interior.ColorIndex = xlNone 'enlève les couleurs aux colonne A à H
    Set pl = .Range("A2:A" & dl) 'définit la plage pl
    Set dico = CreateObject("Scripting.Dictionary") 'définit le dictionnaire dico

    '***************************************
    'récupération des codes PTF sans doublon
    '***************************************
    For Each cel In pl 'boucle sur toutes les cellules cel de la plage pl
        dico(cel.Value) = "" 'alimente le dictionnaire dico
    Next cel 'prochaine cellule de la boucle
    temp = dico.keys 'récupère les valeurs sans doublon

    '********************
    'Filtage par code PTF 
    '********************
    For x = LBound(temp) To UBound(temp) 'boucle de la première à la dernière valeur du tableau temp
        .Range("A1").AutoFilter Field:=1, Criteria1:=temp(x) 'filtre par rapport à la valeur

        '****************
        'Doublons sur ISN
        '****************
        For Each cel In pl.Offset(0, 2).SpecialCells(xlCellTypeVisible) 'boucle sur toutes les cellules filtrées de la colonne C
            pa = cel.Address 'définit la première adresse pa
            Set r = pl.Offset(0, 2).SpecialCells(xlCellTypeVisible).Find(Left(cel.Value, 9), cel, xlValues, xlPart) 'définit la recherche r
            If Not r Is Nothing And r.Address <> cel.Address Then 'condition : si il existe une occurrence ailleurs qu'en pa
                Do 'exécute
                    li = r.Row 'définit la ligne li
                    .Cells(li, 1).Interior.ColorIndex = 50 'couleur verte colonne A
                    .Cells(li, 3).Interior.ColorIndex = 50 'couleur verte colonne C
                    .Cells(li, 4).Interior.ColorIndex = 50 'couleur verte colonne D
                    .Cells(li, 5).Interior.ColorIndex = 50 'couleur verte colonne E
                    Set r = pl.Offset(0, 2).SpecialCells(xlCellTypeVisible).FindNext(r) 'redéfinit la recherche r (occurrence suivante)
                Loop While Not r Is Nothing And r.Address <> pa 'boucle tant qu'il existe des occurrences ailleurs qu'en pa
            End If 'fin de la condition
        Next cel 'prochaine cellule de la boucle
        Set r = Nothing 'initialise r
        pa = "" 'initialise pa

        '********************
        'Doublons sur Libellé
        '********************
        For Each cel In pl.Offset(0, 3).SpecialCells(xlCellTypeVisible) 'boucle sur toutes les cellules filtrées de la colonne D
            'Condition : si le nombre d'occurrence de la valeur de la cellule est supérieur à 1 et si la cellule n'est pas colorée de vert
            If Application.WorksheetFunction.CountIf(pl.Offset(0, 3).SpecialCells(xlCellTypeVisible), cel.Value) > 1 And cel.Interior.ColorIndex <> 55 Then
                Set r = pl.Offset(0, 3).SpecialCells(xlCellTypeVisible).Find(Left(cel.Value, 9), , xlValues, xlPart) 'définit la recherche r
                pa = r.Address 'définit la première adressse pa
                Do 'exécute
                    li = r.Row 'définit la ligne li
                    .Cells(li, 1).Interior.ColorIndex = 50 'couleur verte colonne A
                    .Cells(li, 3).Interior.ColorIndex = 50 'couleur verte colonne C
                    .Cells(li, 4).Interior.ColorIndex = 50 'couleur verte colonne D
                    .Cells(li, 5).Interior.ColorIndex = 50 'couleur verte colonne E
                    Set r = pl.Offset(0, 3).SpecialCells(xlCellTypeVisible).FindNext(r) 'redéfinit la recherche r (occurrence suivante)
                Loop While Not r Is Nothing And r.Address <> pa 'boucle tant qu'il existe des occurrences ailleurs qu'en pa
            End If 'fin de la condition
        Next cel 'prochaine cellule de la boucle
    Next x 'prochaine valeur du tableau temp

.Range("A1").AutoFilter 'supprime le filtre automatique
End With 'fin de la prise en compte de l'onglet "Feuil1"
Application.ScreenUpdating = True 'affiche les changements à l'écran
Application.Calculation = xlAutomatic 'calcul automatique
End Sub

Le fichier :

 

[agadiroufla]

Re : mettre en evidence Doublons et +

Merci infinimenet
ca marche tres bien
Cdlt.

 

[agadiroufla]

Re : mettre en evidence Doublons et +

Bonsoir,
Merci beaucoup Robert pour tes commentaires. j avoue ton code tourne 10 fois plus rapidement, mais beaucoup plus complexe pour moi. Je vais essayer de le retravailler pour mieux le comprendre.
Bonne soirée.

 

[agadiroufla]

Re : mettre en evidence Doublons et +

Au passage j en profite pour te demander a quoi sert le dictionnaire ?
Merci.