XL 2019 Mise en forme conditionnel, doublon

Yazeubi

Yazeubi

XLDnaute Junior
Bonjour j'espère que tout le monde va bien,

Voici ma demande:
J'aimerai à l'aide d'une mise en forme conditionnelle, marquer en rouge les références dans chaque cellules en doublon.
Exemple :

Cellule n°1 :
-A24941A
-A21758A

Cellule n°2 :
-A24941A
-A23589A

La référence A24941A doit apparaître en rouge car elle est présente en double. Toute la cellule ne doit pas être en rouge car toute la cellule n'est pas en double.
J'aimerai que la mise en forme conditionnel soit présente à l'écrit afin que je puisse la copier coller ou la refaire dans d'autre Excel par la suite.

Merci de votre aide.

Yazeubi🍀
 

Pièces jointes

  • Mise en forme conditionnel doublon.xlsm
    16 KB · Affichages: 8
Trier par date Trier par votes
mapomme

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonjour à tous,

Une macro VBA dans le module de la feuille "Feuil1" Cliquer sur le bouton Hop!

Le code :
VB: 
Sub doublons()
Dim der&, dic, t, i&, j&, s, clef, ligne
   Application.ScreenUpdating = False
   If Me.FilterMode Then Me.ShowAllData
   Columns("f").Font.ColorIndex = xlColorIndexAutomatic
   der = Cells(Rows.Count, "f").End(xlUp).Row
   Set dic = CreateObject("scripting.dictionary")
   t = Range("f1:f" & der)
 
   For i = 2 To UBound(t)
      t(i, 1) = Replace(t(i, 1), Chr(10), " ")
      t(i, 1) = Application.Trim(t(i, 1))
      s = Split(t(i, 1))
      For j = 0 To UBound(s)
         If Not dic.exists(s(j)) Then dic.Add s(j), ""
         dic(s(j)) = Trim(dic(s(j)) & " " & i)
      Next j
   Next i
 
   For Each clef In dic
      s = Split(dic(clef))
      If UBound(s) > 0 Then
         For Each ligne In s
            i = InStr(Cells(Val(ligne), "f"), clef)
            Cells(Val(ligne), "f").Characters(Start:=i, Length:=Len(clef)).Font.Color = vbRed
         Next ligne
      End If
   Next clef
End Sub

edit : bonjour @bhbh :)
 

Pièces jointes

  • Yazeubi- colorer doublon- v1.xlsm
    25.6 KB · Affichages: 5
Dernière édition:
Vote positif 0 Vote négatif
Cousinhub

Cousinhub

XLDnaute Barbatruc
Inactif
Bonjour,
Hello @mapomme :)
Bon, comme je l'avais fait..
Un peu différent, même principe (Dictionary)
:
VB: 
Sub color_doublon()
Dim Tbl, Ke, Tbl_Sp
Dim Prem_Adr As String
Dim Doub As Object
Dim Cel As Range
Dim I As Long
Dim J As Byte, Pos As Byte
Set Doub = CreateObject("Scripting.Dictionary")
Tbl = Range("F2:F" & Cells(Rows.Count, "F").End(xlUp).Row)
Columns("F:F").Font.ColorIndex = xlAutomatic
For I = LBound(Tbl) To UBound(Tbl)
    If InStr(1, Tbl(I, 1), Chr(10)) Then
        Tbl_Sp = Split(Tbl(I, 1), Chr(10))
        For J = LBound(Tbl_Sp) To UBound(Tbl_Sp)
            If Tbl_Sp(J) <> "" Then Doub(Trim(Tbl_Sp(J))) = Doub(Trim(Tbl_Sp(J))) + 1
        Next J
    Else
        If Tbl(I, 1) <> "" Then Doub(Trim(Tbl(I, 1))) = Doub(Trim(Tbl(I, 1))) + 1
    End If
Next I
For Each Ke In Doub.Keys
    If Doub(Ke) > 1 Then
        Set Cel = Columns(6).Find(Ke)
        If Not Cel Is Nothing Then
            Prem_Adr = Cel.Address
            Pos = InStr(1, Cel.Value, Ke)
            Cel.Characters(Pos, Len(Ke)).Font.ColorIndex = 3
            Cel.Offset(, 1) = "X"
            Do
                Set Cel = Columns(6).FindNext(Cel)
                Pos = InStr(1, Cel.Value, Ke)
                Cel.Characters(Pos, Len(Ke)).Font.ColorIndex = 3
                Cel.Offset(, 1) = "X"
            Loop While Not Cel Is Nothing And Cel.Address <> Prem_Adr
        End If
    End If
Next Ke
End Sub

Bonne journée
 
Vote positif 0 Vote négatif
Yazeubi

Yazeubi

XLDnaute Junior
bhbh à dit:
Bonjour,
Hello @mapomme :)
Bon, comme je l'avais fait..
Un peu différent, même principe (Dictionary)
:
VB: 
Sub color_doublon()
Dim Tbl, Ke, Tbl_Sp
Dim Prem_Adr As String
Dim Doub As Object
Dim Cel As Range
Dim I As Long
Dim J As Byte, Pos As Byte
Set Doub = CreateObject("Scripting.Dictionary")
Tbl = Range("F2:F" & Cells(Rows.Count, "F").End(xlUp).Row)
Columns("F:F").Font.ColorIndex = xlAutomatic
For I = LBound(Tbl) To UBound(Tbl)
    If InStr(1, Tbl(I, 1), Chr(10)) Then
        Tbl_Sp = Split(Tbl(I, 1), Chr(10))
        For J = LBound(Tbl_Sp) To UBound(Tbl_Sp)
            If Tbl_Sp(J) <> "" Then Doub(Trim(Tbl_Sp(J))) = Doub(Trim(Tbl_Sp(J))) + 1
        Next J
    Else
        If Tbl(I, 1) <> "" Then Doub(Trim(Tbl(I, 1))) = Doub(Trim(Tbl(I, 1))) + 1
    End If
Next I
For Each Ke In Doub.Keys
    If Doub(Ke) > 1 Then
        Set Cel = Columns(6).Find(Ke)
        If Not Cel Is Nothing Then
            Prem_Adr = Cel.Address
            Pos = InStr(1, Cel.Value, Ke)
            Cel.Characters(Pos, Len(Ke)).Font.ColorIndex = 3
            Cel.Offset(, 1) = "X"
            Do
                Set Cel = Columns(6).FindNext(Cel)
                Pos = InStr(1, Cel.Value, Ke)
                Cel.Characters(Pos, Len(Ke)).Font.ColorIndex = 3
                Cel.Offset(, 1) = "X"
            Loop While Not Cel Is Nothing And Cel.Address <> Prem_Adr
        End If
    End If
Next Ke
End Sub

Bonne journée
Cliquez pour agrandir...
Bonjour @bhbh,

Cela marche super bien, j'ai une petite demande c'est que la macro se réactualise dès lors que je rentre une nouvelle référence. Ou seconde option quel se réactualise à l'ouverture de l'excel.
Car j'ai remarqué que si je rentre une nouvelle ref qui est en doublon elle ne devient pas rouge.

Merci pour le travail c'est super !
 
Vote positif 0 Vote négatif
Yazeubi

Yazeubi

XLDnaute Junior
mapomme à dit:
Bonjour à tous,

Une macro VBA dans le module de la feuille "Feuil1" Cliquer sur le bouton Hop!

Le code :
VB: 
Sub doublons()
Dim der&, dic, t, i&, j&, s, clef, ligne
   Application.ScreenUpdating = False
   If Me.FilterMode Then Me.ShowAllData
   Columns("f").Font.ColorIndex = xlColorIndexAutomatic
   der = Cells(Rows.Count, "f").End(xlUp).Row
   Set dic = CreateObject("scripting.dictionary")
   t = Range("f1:f" & der)
 
   For i = 2 To UBound(t)
      t(i, 1) = Replace(t(i, 1), Chr(10), " ")
      t(i, 1) = Application.Trim(t(i, 1))
      s = Split(t(i, 1))
      For j = 0 To UBound(s)
         If Not dic.exists(s(j)) Then dic.Add s(j), ""
         dic(s(j)) = Trim(dic(s(j)) & " " & i)
      Next j
   Next i
 
   For Each clef In dic
      s = Split(dic(clef))
      If UBound(s) > 0 Then
         For Each ligne In s
            i = InStr(Cells(Val(ligne), "f"), clef)
            Cells(Val(ligne), "f").Characters(Start:=i, Length:=Len(clef)).Font.Color = vbRed
         Next ligne
      End If
   Next clef
End Sub

edit : bonjour @bhbh :)
Cliquez pour agrandir...
Bonjour @mapomme,

Le travail répond à ma demande c'est vraiment top, le seul point d'amélioration, serait une réactualisation automatique du vba lors de l'ajout de référence au lieu de l'utilisation d'un bouton VBA.
Car j'ai remarqué que si je rentre une nouvelle ref qui est en doublon elle ne devient pas rouge.

Merci pour ton travail.

Bonne soirée.

Yazeubi
 
Vote positif 0 Vote négatif

Discussions similaires

A
  • Question
XL 2019 Mise en forme conditionnelle
Réponses
5
Affichages
235
wDog66
wDog66
T
  • Question
Microsoft 365 Mise en forme conditionnelle
Réponses
5
Affichages
141
TooFatBoy
TooFatBoy
H
  • Question
XL 2021 *RESOLU* Formule de mise en forme conditionnelle
Réponses
8
Affichages
455
hades
H
C
  • Résolu(e)
XL 2021 Mise en forme conditionnelle si *mot* dans cellule
Réponses
10
Affichages
286
TooFatBoy
TooFatBoy
B
  • Question
Microsoft 365 Excel - Mise en forme conditionnelle
Réponses
6
Affichages
292
Benouze
B
A
  • Question
Microsoft 365 Mise en forme conditionnel avec formule qui ne répond pas à des critères
Réponses
2
Affichages
337
TooFatBoy
TooFatBoy
L
  • Question
Microsoft 365 mise en forme fichier excel power query
Réponses
1
Affichages
108
vgendron
vgendron
F
  • Question
XL 2016 Mise en forme conditionnelle d'une forme (cartographie)
Réponses
9
Affichages
267
francois95
F
M
  • Question
XL pour MAC Mise en forme conditionnel
Réponses
3
Affichages
537
manuBX
M
J
  • Question
XL 2010 mise en forme conditionnelle
2
Réponses
19
Affichages
908
Jacflddu49
J

Membres actuellement en ligne

23 membres et 137 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 094
Messages
2 116 145
Membres
112 669
dernier inscrit
Guigui2502