Microsoft 365 Copier juste couleur cellule.

Francky79

XLDnaute Occasionnel
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
 

Pièces jointes

  • Copie état.xlsm
    31.1 KB · Affichages: 10
Solution
OK alors :
VB:
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

job75

XLDnaute Barbatruc
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 :
VB:
Sub a()
Feuil1.[R6].Interior.Color = Feuil1.[Q6].DisplayFormat.Interior.Color
End Sub
A+
 

job75

XLDnaute Barbatruc
OK alors :
VB:
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

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

VB:
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

XLDnaute Barbatruc
Bonjour Francky79,

Bah il suffit de faire en sorte que le 1er test ne bloque pas la macro :
VB:
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+
 

Discussions similaires

Réponses
2
Affichages
134
Réponses
2
Affichages
214

Statistiques des forums

Discussions
313 198
Messages
2 096 142
Membres
106 505
dernier inscrit
ngomez