XL 2013 Surligner les doublons mais pas la première Occurrence

[Doze]

Bonjour à tous,

Je recherche à surligner tout les doublons sauf la première occurrence dans une colonne précise d'un fichier d'environs 50000 à 60000 ligne, comme dans l'exemple ci dessous

Mon code VBA pour le moment est le suivant

Sub RechercherDoublons()

  Dim col, nbCells, i, j

  col = ActiveCell.Column

  nbCells = Application.WorksheetFunction.CountA(Range(Columns(col), Columns(col)))

  For i = 1 To nbCells - 1

    For j = i + 1 To nbCells

      If Cells(i, col) = Cells(j, col) Then

        Cells(j, col).Interior.Color = RGB(255, 0, 0)

      End If

    Next j

  Next i

End Sub

Cela marche très bien pour de petit tableau mais lors de l'exécution sur mon fichier de base cela fait planter excel. Petite précision nous utilisons encore excel 2013 et nos ordinateurs ne sont pas extrêmement performant.

Auriez vous des pistes pour Améliorer mon code pour l'utilisation sur un fichier conséquent ? J'utilise de base Javascript et je découvre tout juste VBA.

Merci beaucoup aux personnes qui prendront le temps de me répondre.

Bonne fin de week end à tous.

 

[Dudu2]

Bonjour,

En passant par un chargement en mémoire du Range concerné ça devrait aller 7 à 8 fois plus vite.
D'autre part

The COUNTA function counts the number of cells that are not empty in a range.

Donc s'il y a des cellules vides dans la colonne, tu n'atteindras pas la dernière ligne.

#Const TABLEAU_EST_TRIÉ = False

Sub RechercherDoublons()
    Dim TabCol() As Variant
    Dim NoColonne As Long
    Dim NbLignes As Long
    Dim i As Long
    Dim j As Long
 
    With ActiveSheet
        NoColonne = ActiveCell.Column
 
        'Aucune valeur dans la colonne
        If Application.WorksheetFunction.CountA(.Columns(NoColonne)) = 0 Then
            MsgBox "Aucune valeur dans cette colonne"
            Exit Sub
        End If
 
        'Effacement de la colorisation précédente sur toute la colonne
        With .Cells(1, NoColonne).Resize(Rows.Count).Interior
            .Pattern = xlNone
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
 
        'Défiltrer pour ne pas fausser le xlUp avec des lignes de fin filtrées
        If Not .AutoFilter Is Nothing Then .AutoFilter.ShowAllData
        NbLignes = .Cells(Rows.Count, NoColonne).End(xlUp).Row
 
        'Chargement de la colonne en table
        TabCol = .Cells(1, NoColonne).Resize(NbLignes).Value
 
        'Détection des doublons et colorisation
        For i = 1 To UBound(TabCol, 1) - 1
            If TabCol(i, 1) <> vbEmpty Then
                For j = i + 1 To UBound(TabCol, 1)
                    If TabCol(j, 1) = TabCol(i, 1) Then
                        .Cells(j, NoColonne).Interior.Color = RGB(255, 0, 0)
#If TABLEAU_EST_TRIÉ Then
                    ElseIf TabCol(j, 1) > TabCol(i, 1) Then
                        Exit For
#End If
                    End If
                Next j
            End If
        Next i
    End With
End Sub

Edit:
Pour info, le chargement d'un Range en table donne toujours une table à 2 dimensions (lignes x colonnes) même s'il n'y a qu'une seule colonne. Les LBound des 2 dimensions sont toujours 1.
C'est bon à savoir car certaines fonctions (par exemple un Split) rendent une table dont le LBound est 0. Ceci dit si tu utilises toujours le LBound d'une dimension d'une table (ce que je n'ai PAS fait dans ce code !) tu ne risques pas de te tromper.
Si je l'avais fait, ce serait plus "strict" mais moins lisible:

    'Détection des doublons et colorisation
    For i = LBound(TabCol, 1) To UBound(TabCol, 1) - 1
        If TabCol(i, LBound(TabCol, 2)) <> vbEmpty Then
            For j = i + 1 To UBound(TabCol, 1)
                If TabCol(i, LBound(TabCol, 2)) = TabCol(j, LBound(TabCol, 2)) Then
                    .Cells(j, NoColonne).Interior.Color = RGB(255, 0, 0)
                End If
            Next j
        End If
    Next i

 

[job75]

Bonsoir Doze, bienvenue sur XLD, Dudu2,

Pas besoin de VBA, voyez le fichier joint et la formule de la MFC sur la colonne A :

=(NB.SI(A:A;A1)>1)*(LIGNE(A1)>EQUIV(A1;A:A;0))

Le tableau a 60 000 lignes et fonctionne sans problème.

A+

 

[Dudu2]

Bonsoir @job75,
Tu as entièrement raison.
@Doze a quand même le choix d'un VBA si c'est nécessaire.

 

[job75]

Si l'on veut utiliser le VBA il faut absolument éviter les 2 boucles imbriquées.

Utiliser une seule boucle avec le Dictionary, c'est archi classique, Dudu2 tu sais le faire.

Bonne nuit.

 

[Dudu2]

Bonjour @job75,

Utiliser une seule boucle avec le Dictionary, c'est archi classique, Dudu2 tu sais le faire.

Je suis étonné que tu proposes ça. Le Dictionary est d'une lenteur sénatoriale.
Mais ce serait intéressant de faire un essai pour voir la différence.
Avec un tableau trié, c'est plié que c'est la double boucle comme adaptée ci-dessus.
Avec un tableau non trié à voir.

 

[job75]

Bonjour Dudu2, le forum,

Je suis étonné que tu proposes ça. Le Dictionary est d'une lenteur sénatoriale.

Je suis étonné que tu ne connaisses pas les performances du Dictionary :

Sub Colorer_doublons()
Dim t, d As Object, tablo, i&, v$
t = Timer
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
With ActiveSheet.UsedRange.Columns(1) 'colonne à adapter
    .Interior.ColorIndex = xlNone 'RAZ
    tablo = .Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
    For i = 1 To UBound(tablo)
        v = CStr(tablo(i, 1))
        If v <> "" Then
            If d.exists(v) Then .Cells(i, 1).Interior.ColorIndex = 44 Else d(v) = ""
        End If
    Next
End With
MsgBox "Durée " & Format(Timer - t, "0.00 \sec") 'mesure facultative
End Sub

Sur 60 000 lignes et 3 doublons => 0,16 seconde chez moi.

A+

 

[Doze]

Merci à toi @Dudu2 pour cette réponse détaillé, je vais essayer de bien comprendre le paradigme de ta réponse, pour écrire mon propre code.

@job75 Merci pour la découverte du Dictionary c'est quelque chose que je ne connaissait pas du tout. J'avais pris l'option de la MFC mais je préfère vraiment passer par VBA pour développer mes capacités.

Vos réponses m'apporte grandement pour la réalisation de mon code. Encore merci à vous deux.

 

[Usine à gaz]

Bonjour le Forum, Bonjour Gérard,
Chez moi 0.29 ... très rapide
lionel,

 

[mapomme]

Le Dictionary est d'une lenteur sénatoriale.

Ah ben v'là ti aut'chose (bonjour @Dudu2 et à tous les autres...)

 

[job75]

J'avais pris l'option de la MFC mais je préfère vraiment passer par VBA pour développer mes capacités.

Bah colorer les cellules prend du temps en VBA s'il y en a beaucoup à colorer.

Testez en mettant un 1 dans toutes les cellules de la plage A1:A60000.

Avec une MFC c'est immédiat, en VBA il faut chez moi 1,7 seconde.

Salut mapomme

 

[Dudu2]

@job75,
Je dois admettre que tu as encore une fois raison.
Si le tableau n'est pas trié ton code est 840 fois plus rapide ! J'en ai viré mon code ridicule pour ne pas confuser le demandeur !
Sur un tableau trié le code du post #2 semble plus rapide dans un rapport que je ne peux pas calculer car il varie de -0.02 sec à 0.16 sec. Mais à ce niveau ça n'a plus d'importance.

 

[Dudu2]

@Doze,
Si tu veux utiliser du VBA à titre d'exercice, pourquoi pas.
D'ailleurs une autre solution consisterait à définir la MFC de @job75 en VBA sur la colonne active, en supprimant si besoin celles sur les autres colonnes portant la même formule.

 

[mapomme]

Bonjour à @Doze, @Dudu2, @job75 et @Usine à gaz

Une autre méthode utilisant du VBA sans "dictionary" (donc compatible Apple) et très rapide.
Dans le fichier les deux méthodes : celle de @job75 et celle de ma pomme.
Il y a 60.000 lignes dont 23 418 doublons colorés.
Cliquez sur un des deux boutons.

Le code:

Sub SansDico()
Dim derlig&, Source As Worksheet, wks As Object, nada, ok As Boolean, t, x, i&, ref, deb
   deb = Timer
   Set Source = ActiveSheet
   Application.ScreenUpdating = False
   If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
   derlig = Cells(Rows.Count, "a").End(xlUp).Row
   Range("a1").Resize(derlig, 2).Interior.ColorIndex = xlColorIndexNone
   t = Range("a1").Resize(derlig, 2)
   For i = 1 To derlig: t(i, 2) = i: Next
   On Error Resume Next
   Set wks = ThisWorkbook.Worksheets.Add
   If wks Is Nothing Then MsgBox "Erreur création feuille tempo => échec et fin!": Exit Sub
   On Error GoTo Fin
   With wks
      .Range("a1").Resize(derlig, 2) = t
      .Range("a1").Resize(derlig, 2).Sort key1:=.Columns(1), Header:=xlNo
      t = .Range("a1").Resize(derlig, 2)
      For i = 2 To derlig
         If t(i, 1) = t(i - 1, 1) Then Source.Cells(t(i, 2), 1).Interior.Color = RGB(160, 241, 254)
      Next i
   End With
   Application.DisplayAlerts = False: wks.Delete: Application.DisplayAlerts = True
   Source.Cells(Rows.Count, "d").End(xlUp).Offset(1) = Format(Timer - deb, "0.00\ sec.")
   Exit Sub
Fin:
   Application.DisplayAlerts = False: wks.Delete: Application.DisplayAlerts = True
   MsgBox "Erreur au sein de la macro => Echec!"
End Sub

 

[Dudu2]

Pour les doublons en MFC.

Sub DoublonsEnMFC()
    Dim Formule As String
    Dim i As Integer
    Dim t As Long
    '
    Const SupprimePrélablementToutesLesMFCDoublonsEnFeuille = True
    'Const SupprimePrélablementToutesLesMFCDoublonsEnFeuille  = False
    Const ColorIndexDoublons = 44
    Const FormuleDoublons = "=(NB.SI($%:$%;$%@)>1)*(LIGNE($%@)>EQUIV($%@;$%:$%;0))" 'Remplacer % par la lettre de la colonne concernée
                                                                                    'Remplacer @ par la 1ère ligne ou masque nombre E.R.
 
t = Timer
    Application.ScreenUpdating = False
 
    With ActiveSheet.Cells
        If SupprimePrélablementToutesLesMFCDoublonsEnFeuille Then
            'Suppression des MFC des doublons de toutes les colonnes
            Formule = Replace(Replace(FormuleDoublons, "%", "?"), "@", "#*")
        Else
            'Suppression des MFC des doublons de la colonne active
            Formule = Replace(Replace(FormuleDoublons, "%", LettreColonne(ActiveCell.Column)), "@", "#*")
        End If
    
        i = 1
        Do While i <= .FormatConditions.Count
            With .FormatConditions(i)
                If .Type = 2 Then
                    If .Formula1 Like Formule Then
                        .Delete
                        i = i - 1
                    End If
                End If
                i = i + 1
            End With
        Loop
    End With
 
    'Ajout de la MFC des doublons sur la colonne active
    With ActiveSheet.Columns(ActiveCell.Column).Cells
        .FormatConditions.Add Type:=xlExpression, _
            Formula1:=Replace(Replace(FormuleDoublons, "%", LettreColonne(ActiveCell.Column)), "@", "1")
        .FormatConditions(.FormatConditions.Count).Interior.ColorIndex = ColorIndexDoublons
        .FormatConditions(.FormatConditions.Count).StopIfTrue = False
    End With
MsgBox "Durée " & Format(Timer - t, "0.00 \sec") 'mesure facultative
End Sub

Function LettreColonne(NoColonne As Integer) As String
    LettreColonne = Split(Cells(1, NoColonne).Address, "$")(1)
End Function