Const nlig& = 12 'hauteur des tableaux, modifiable
Const ncol% = 4 'largeur des tableaux, modifiable
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim d As Object, c As Range, x$, P As Range
If Target.Column > 1 Or (Target.Row - 1) Mod nlig Then Exit Sub
Cancel = True
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For Each c In Target.Resize(nlig, ncol)
If c <> "" And c.Interior.ColorIndex <> xlNone Then
x = c & Chr(1) & c.Interior.Color
If d.exists(x) Then
Set P = Union(Range(d(x)), IIf(P Is Nothing, c, P), c)
Else
d(x) = c.Address
End If
End If
Next
If P Is Nothing Then
MsgBox "C'est tout bon...", , "Vérification des doublons"
Else
P.FormatConditions.Add Type:=xlExpression, Formula1:="=VRAI" 'création de la MFC
P.FormatConditions(1).Interior.ColorIndex = 49 'bleu foncé
P.FormatConditions(1).Font.ColorIndex = 2 'police blanche
P.FormatConditions(1).Font.Bold = True 'gras
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
[A:A].Resize(, ncol).FormatConditions.Delete 'RAZ
End Sub