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]

Petite modif ci-dessus pour ajouter l'option d'appliquer la MFC uniquement sur la colonne active via la constante bien nommée SupprimePrélablementToutesLesMFCDoublonsEnFeuille !

 

[mic6259]

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

Bonjour ma pomme, le code m'intéresse.
Serait il possible de faire de rechercher sur une plage de la feuille définie, par exemple en A1:J30, ou toute la feuille ?
Merci beaucoup

 

[job75]

Bonjour mic6259,

Le code de mapomme a l'avantage d'éviter le Dictionary grâce à un tri.

Mais cela a lieu sur une seule colonne.

Sur plusieurs colonnes le mieux est de revenir au Dictionary.

A+

 

[mic6259]

Bonjour mic6259,

Le code de mapomme a l'avantage d'éviter le Dictionary grâce à un tri.

Mais cela a lieu sur une seule colonne.

Sur plusieurs colonnes le mieux est de revenir au Dictionary.

A+

Pourriez vous le faire ?.
J'ai votre fichier avec Dictionary
Merci job

 

[mapomme]

Serait il possible de faire de rechercher sur une plage de la feuille définie, par exemple en A1:J30, ou toute la feuille ?

Je ne comprends pas la question !

 

[job75]

Pourriez vous le faire ?.
J'ai votre fichier avec Dictionary

Ce n'est guère compliqué voyez ce fichier (2) et la macro :

Private Sub Worksheet_Calculate()
Dim t, d As Object, tablo, ncol%, i&, j%, x$, n&
t = Timer
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
With UsedRange
    .Interior.ColorIndex = xlNone 'RAZ
    tablo = .Value 'matrice, plus rapide
    ncol = UBound(tablo, 2)
    For i = 1 To UBound(tablo)
        For j = 1 To ncol
            x = tablo(i, j)
            If x <> "" Then
                If d.exists(x) Then
                    n = n + 1
                    .Cells(i, j).Interior.ColorIndex = 44 'orange
                Else
                    d(x) = ""
                End If
            End If
    Next j, i
End With
MsgBox n & " cellules colorées en " & Format(Timer - t, "0.00 \sec")
End Sub

Elle se déclenche quand les formules (volatiles) sont recalculées.

Salut mapomme.

 

[mic6259]

Je ne comprends pas la question !

Sur ton fichier, la recherche doublon se fait sur une colonne. Serait il possible de le faire sur une plage sélectionnée ?

 

[mic6259]

Sur ton fichier, la recherche doublon se fait sur une colonne. Serait il possible de le faire sur une plage sélectionnée ?

Excusez-moi je me suis trompé de fichier que vous avez mis dans ce forum
Je le mets pour comprendre par rapport a ma question plus haut.
Merci beaucoup job et mapomme