Microsoft 365 afficher les doublon avec des couleurs

• Avec Excel VBA en utilisant des expressions régulières :
• Modifier "Feuil1" : ThisWorkbook.Sheets("Feuil1") par le nom de la feuille où sont les données.
• Cette macro va parcourir toutes les cellules de la colonne A, rechercher des mots et les mettre en rouge s'ils sont des doublons.

Option Explicit
'
Sub ColorizeDuplicates()
  Dim rng As Range
  Dim cell As Range
  Dim dict As Object
  Dim regex As Object
  Dim matches As Object
  Dim match As Object
'
' Créer un dictionnaire pour stocker les valeurs et leurs occurrences
    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)
'
' Parcourir chaque cellule dans la plage spécifiée
    For Each cell In rng
    ' Réinitialiser les correspondances
        Set matches = regex.Execute(cell.Value)
       
            ' Parcourir 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
                                cell.Characters(InStr(LCase(cell.Value), LCase(match.Value)), Len(match.Value)).Font.Color = RGB(255, 0, 0) ' Rouge
                        Else
                            ' Sinon, ajouter le mot au dictionnaire
                                dict(LCase(match.Value)) = 1
                        End If
                Next match
    Next cell
'
' Nettoyer les objets
    Set dict = Nothing
    Set regex = Nothing
    Set rng = Nothing
    Set cell = Nothing
    Set matches = Nothing
    Set match = Nothing
'
End Sub

• For Each cell In rng, chacune appelant la fonction ProcessCell (avec des dictionnaires différents dans un ordre spécifique) :
  • La première boucle For Each cell In rng utilise dictPremier comme premier dictionnaire, ce qui signifie que les mots rencontrés pour la première fois seront ajoutés à ce dictionnaire.
  • Ensuite, la deuxième boucle For Each cell In rng utilise dict comme premier dictionnaire, ce qui signifie que les mots déjà rencontrés seront ajoutés à ce dictionnaire.

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

mapomme à dit:

Bonjour à toutes, à tous et aux autres ,

@HASSEN@45 ,
De nombreux répondeurs se sont penchés sur votre question pour finalement constater que le fichier fourni diffère de "l'image" de la première question : notamment un nombre variable de villes pouvant être supérieur à 2, les données ne commencent qu'à la ligne 4, etc. Pourquoi ne pas avoir fourni un exemplaire de fichier dès le début (tel qu'il est conseillé dans la charte du site) ? Allez! Vous ferez mieux la prochaine fois !

Cliquez pour agrandir...

Staple1600 à dit:

Bonjour le fil

@mapomme (bon dimanche)
Sans oublier la non-anonymisation de la colonne Transporteur
(sujet également évoqué dans la charte du forum)
@HASSEN@45
Le forum offre une fonction d'édition des messages
(pour modifier le contenu du message et pour supprimer et modifier les pièces)
Tu n'as donc pas à attendre la prochaine fois pour corriger ton message#9

Cliquez pour agrandir...

mapomme à dit:

Re,

Un essai dans le fichier joint via une macro VBA (n'est-ce pas @Staple1600 ).
Cliquer sur le bouton Hop! de la feuille "John".
La macro est dans Module1. Elle agit sur la feuille active.

nota : on a utilisé la dernière version du classeur que vous avez fourni en anonymisant les transporteurs .

rem : préférez la version v2a qui a été débarrassée de ses deux instructions "DoEvents" inutiles qui n'étaient présentes que pour la mise au point.

Cliquez pour agrandir...

laurent950 à dit:

Bonsoir @HASSEN@45

J'ai optimisé le code en divisant le traitement des doublons en deux étapes distinctes. C'est une astuce pour gérer les doublons sans traiter les mêmes mots à plusieurs reprises.

Dans cette version modifiée, j'ai divisé le traitement en deux boucles

• For Each cell In rng, chacune appelant la fonction ProcessCell (avec des dictionnaires différents dans un ordre spécifique) :
  • La première boucle For Each cell In rng utilise dictPremier comme premier dictionnaire, ce qui signifie que les mots rencontrés pour la première fois seront ajoutés à ce dictionnaire.
  • Ensuite, la deuxième boucle For Each cell In rng utilise dict comme premier dictionnaire, ce qui signifie que les mots déjà rencontrés seront ajoutés à ce dictionnaire.

Conclusion : Cela permet d'éviter de colorier les premières occurrences de doublons, car elles sont gérées dans la première boucle avec dictPremier, tandis que les occurrences suivantes sont colorées dans la deuxième boucle avec dict. Cette approche permet de ne colorier que les doublons, pas les mots uniques.

Je pense que c'est une astuce ingénieuse pour optimiser le traitement des doublons dans le code.

Code:

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

Cliquez pour agrandir...