Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim cible As Range, P As Range, t, nlig&, ncol%, coul()
Dim d As Object, d1 As Object, i&, j%, x&, a, k&, b
Set cible = [G3] 'à adapter
If Intersect(Target, cible) Is Nothing Then Exit Sub
Cancel = True
Application.ScreenUpdating = False
cible(2).Resize(Rows.Count - cible.Row).ClearContents 'RAZ
Set P = Me.UsedRange
If P.Count = 1 Then If P.Interior.ColorIndex <> xlNone Then cible(2) = P: Exit Sub
t = P 'matrice
nlig = P.Rows.Count: ncol = P.Columns.Count
ReDim coul(1 To nlig, 1 To ncol)
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
'---liste des couleurs et mémorisation---
For i = 1 To nlig
For j = 1 To ncol
If P(i, j).Interior.ColorIndex <> xlNone Then
x = P(i, j).Interior.Color
d(x) = ""
coul(i, j) = x
End If
Next j, i
If d.Count = 0 Then Exit Sub
'---analyse de chaque couleur et des valeurs---
a = d.keys: d.RemoveAll
For k = 0 To UBound(a)
d1.RemoveAll
For i = 1 To nlig
For j = 1 To ncol
If coul(i, j) <> "" Then _
If coul(i, j) = a(k) Then _
If k Then d1(t(i, j)) = "" Else d(t(i, j)) = ""
Next j, i
If d.Count = 0 Then Exit Sub
If k Then
If d1.Count = 0 Then Exit Sub
b = d.keys
For i = 0 To UBound(b)
If Not d1.exists(b(i)) Then d.Remove b(i)
Next i
End If
Next k
If d.Count = 0 Then Exit Sub
'--- restitution---
cible(2).Resize(d.Count) = Application.Transpose(d.keys)
End Sub