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

Doze

XLDnaute Nouveau
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

ze.PNG



Mon code VBA pour le moment est le suivant


VB:
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.
 

mic6259

XLDnaute Occasionnel
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:
VB:
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

XLDnaute Barbatruc
Pourriez vous le faire ?.
J'ai votre fichier avec Dictionary
Ce n'est guère compliqué voyez ce fichier (2) et la macro :
VB:
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.
 

Pièces jointes

  • VBA comme MFC(2).xlsm
    687.9 KB · Affichages: 4

mic6259

XLDnaute Occasionnel
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
 

Pièces jointes

  • Doze- colorer doublons- v1 (1).xlsm
    337.1 KB · Affichages: 5

Statistiques des forums

Discussions
298 029
Messages
1 965 287
Membres
200 895
dernier inscrit
Lisa Lisa