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

Doze · 23 Octobre 2021

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

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.

Dudu2 · 24 Octobre 2021

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 · 26 Octobre 2021

mapomme à dit:

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 · 26 Octobre 2021

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 · 26 Octobre 2021

job75 à dit:
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 · 26 Octobre 2021

mic6259 à dit:
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 · 26 Octobre 2021

mic6259 à dit:
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.

mic6259 · 26 Octobre 2021

mapomme à dit:
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 · 26 Octobre 2021

mic6259 à dit:
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

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

Doze

XLDnaute Nouveau

Dudu2

XLDnaute Barbatruc

mic6259

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

mic6259

XLDnaute Occasionnel

mapomme

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

mic6259

XLDnaute Occasionnel

mic6259

XLDnaute Occasionnel

Pièces jointes

Discussions similaires