XL 2019 Mise en forme conditionnel, doublon

djidji59430 à dit:

Bonjour à tous,

Une proposition avec données==>obtenir des données

Cliquez pour agrandir...

chris à dit:

Bonjour
La mise en forme d'une MFC ne peut s'appliquer sur une portion de contenu
Seul VBA peut le faire

Cliquez pour agrandir...

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

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

mapomme à dit:

Re,

Voir la v2.

Modifiez ou re-validez une cellule en colonne F.

Cliquez pour agrandir...