Microsoft 365 Copier juste couleur cellule.

[Francky79]

Bonjour,

je recherche le moyen de copier juste la couleur de fond (la couleur résulte d'une MFC) d'une cellule sur une autre feuille en VBA mais sans la MFC.
Double clic dans une cellule, insertion de la date, copier couleur cellule, recherche de la ligne correspondante sur feuille base et copier la couleur.
Voir fichier en pièce jointe, le code est de ma conception avec ma connaissance en VBA qui n'est pas très grande

Merci pour votre aide

 

[job75]

Bonjour Francky79,

Je n'ai pas compris vos explications.

Si vous voulez copier en R6 la couleur affichée de la cellule Q6 c'est simple :

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

A+

 

[Francky79]

Bonjour job75,

Merci pour votre aide, mais les cellules sont variables d'une feuille à l'autre suivant la recherche sur la colonne A de la deuxième feuille, plus explications dans le fichier.

 

[job75]

OK alors :

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

 

[Francky79]

Merci job75,

Ca ma l'air parfait.

 

[Francky79]

Juste un petit problème, j'ai déjà un code dans le BeforeDoubleClick et le deuxième code ne marche plus, comment remédier à ce problème ?
Merci pour votre aide.

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

 

[job75]

Bonjour Francky79,

Bah il suffit de faire en sorte que le 1er test ne bloque pas la macro :

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

A+

 

[Francky79]

Merci job75,

Forcement je n'avais pas enlever le Exit Sub sur la première ligne.

Encore merci,