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

M
  • Question
XL pour MAC Mise en forme conditionnel
Réponses
3
Affichages
345
manuBX
M
A
  • Résolu(e)
XL 2016 Mise en forme conditionnel
Réponses
6
Affichages
209
mapomme
mapomme
L
  • Résolu(e)
Microsoft 365 VBA - Attribuer mise en forme en fonction de valeur cellule d'une liste
Réponses
14
Affichages
288
Laliepomm
L
R
  • Question
XL 2019 Mise en forme conditionnelle
Réponses
4
Affichages
71
Nain porte quoi
N
J
  • Question
XL 2021 mise en forme conditionnelle et cellules vides.
Réponses
2
Affichages
171
JOGA
J
anthonygg
  • Résolu(e)
XL 2010 Mise en forme conditionnelle sur toute la ligne ?
Réponses
4
Affichages
262
anthonygg
anthonygg
M
  • Question
XL 2021 Mise en Forme Conditionnelle avec Formule Complexe
Réponses
4
Affichages
197
sylvanu
sylvanu
M
  • Résolu(e)
XL 2016 mise en forme conditionnelle
Réponses
7
Affichages
337
TooFatBoy
TooFatBoy
F
  • Résolu(e)
Microsoft 365 Mise en forme conditionnelle selon la référence d'une cellule
Réponses
3
Affichages
83
filiph79
F
Y
  • Question
XL 2019 Mise en forme conditionnelle
Réponses
2
Affichages
318
YOU06
Y

Membres actuellement en ligne

Aucun membre en ligne actuellement.
2 membres et 32 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
312 069
Messages
2 085 040
Membres
102 763
dernier inscrit
NICO26