Microsoft 365 Copier juste couleur cellule.

Sub a()
Feuil1.[R6].Interior.Color = Feuil1.[Q6].DisplayFormat.Interior.Color
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Range("AD7:AD1000")) Is Nothing Then Exit Sub
Dim lig As Variant
Cancel = True
Target = Date
With Sheets("Base")
lig = Application.Match(Cells(Target.Row, 1), .Columns("E"), 0)
If IsNumeric(lig) Then .Range("Q" & lig).Interior.Color = Cells(Target.Row, "AR").DisplayFormat.Interior.Color
End With
If Not Intersect([AK6:AK600], Target) Is Nothing Then
a = Array("DCL", "")
p = Application.Match(Target, a, 0)
If IsError(p) Then
Target = a(0)
Else
If p > UBound(a) Then p = 0
Target = a(p)
End If
Cancel = True
End If
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("AD7:AD1000")) Is Nothing Then
    Dim lig As Variant
    Cancel = True
    Target = Date
    With Sheets("Base")
        lig = Application.Match(Cells(Target.Row, 1), .Columns("E"), 0)
        If IsNumeric(lig) Then .Range("Q" & lig).Interior.Color = Cells(Target.Row, "AR").DisplayFormat.Interior.Color
    End With
End If
If Not Intersect([AK6:AK600], Target) Is Nothing Then
    Dim a, p
    a = Array("DCL", "")
    p = Application.Match(Target, a, 0)
    If IsError(p) Then
        Target = a(0)
    Else
        If p > UBound(a) Then p = 0
        Target = a(p)
    End If
    Cancel = True
End If
End Sub