Option Explicit
'
Sub ColorizeDuplicates()
Dim rng As Range
Dim cell As Range
Dim dictPremier As Object ' Le tous premier doublons.
Dim dict As Object ' a partir du Deuxiéme doublons... 3,4,5,6 etc.
Dim regex As Object
' Créer un dictionnaire pour stocker les valeurs et leurs occurrences (premier ensemble)
Set dictPremier = CreateObject("Scripting.Dictionary")
' Créer un dictionnaire pour stocker les valeurs et leurs occurrences (à partir du deuxième ensemble)
Set dict = CreateObject("Scripting.Dictionary")
' Créer une expression régulière pour matcher les mots dans les cellules
Set regex = CreateObject("VBScript.RegExp")
With regex
.Global = True
.IgnoreCase = True
.Pattern = "[a-zA-Z]+"
End With
'
' Spécifier la plage de cellules à vérifier
Set rng = ThisWorkbook.Sheets("Feuil1").Range("A1:A" & ThisWorkbook.Sheets("Feuil1").Cells.SpecialCells(xlCellTypeLastCell).Row)
' Traiter chaque cellule dans la plage spécifiée
For Each cell In rng
ProcessCell cell, dictPremier, dict, regex ' Astuce ici "dictPremier, dict"
Next cell
' Traiter chaque cellule dans la plage spécifiée
For Each cell In rng
ProcessCell cell, dict, dictPremier, regex ' Astuce ici "dict, dictPremier"
Next cell
' Nettoyer les objets
Set dict = Nothing
Set regex = Nothing
Set rng = Nothing
Set cell = Nothing
End Sub
Sub ProcessCell(cell As Range, dictPremier As Object, dict As Object, regex As Object)
' --------->>>>> Astuce : dictPremier As Object, dict As Object
Dim matches As Object
Dim match As Object
' Réinitialiser les correspondances
Set matches = regex.Execute(cell.Value)
' Traiter chaque mot correspondant dans la cellule
For Each match In matches
' Vérifier si le mot est déjà dans le dictionnaire
If dict.Exists(LCase(match.Value)) Then
' Si le mot est un doublon, mettre en couleur la partie correspondante de la cellule en rouge
cell.Characters(InStr(LCase(cell.Value), LCase(match.Value)), Len(match.Value)).Font.Color = RGB(255, 0, 0) ' Red
' Ajouter le mot au dictionnaire du premier ensemble de doublons
dictPremier(LCase(match.Value)) = 1
Else
' Sinon, ajouter le mot au dictionnaire
dict(LCase(match.Value)) = 1
End If
Next match
'
Set matches = Nothing
Set match = Nothing
End Sub
.
