Copier Coller Cellule avec Validation en conservant la couleur

D

dirmon

XLDnaute Junior
Bonjour le Forum

Je bloque sur ce problème depuis longtemps en espérant que qqn puisse m'aider.

Sur le fichier joint dans l'onglet Planning je souhaite copier coller la plage de cellule E3:F30 à partir de la cellule G3

Lorsque je colle la couleur des cellules ne suit pas malgré la mise en place de la macro suivante :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long
Application.ScreenUpdating = False
If Not Intersect([planning], Target) Is Nothing Then
On Error Resume Next
Target.Interior.ColorIndex = [couleurs].Find(Target, LookAt:=xlWhole).Interior.ColorIndex
End If
End Sub

Avez vous une solution ?

PS : Excel 2010

Merci pour votre aide
 

Pièces jointes

  • Couleur Validation Cellule.xlsm
    19.3 KB · Affichages: 51
Trier par date Trier par votes
Speel

Speel

XLDnaute Occasionnel
Re : Copier Coller Cellule avec Validation en conservant la couleur

Bonsoir,
Ta macro dit ;
colorer l'intérieur des cellules en fonction de la valeur trouvée dans la liste "couleurs"

c'est la valeur de la première cellule de la plage sélectionnée qui est recherchée et qui définie la couleur reproduite.

test en sélectionnant E9:F16 et copiant collant en G3 , les cellules seront bleu.
 
Vote positif 0 Vote négatif
D

dirmon

XLDnaute Junior
Re : Copier Coller Cellule avec Validation en conservant la couleur

Bonjour le Forum

Merci Speel mais j'ai adapté la macro différement

Par contre dès que je copie sur les deux premières colonnes nickel mais dès que je passe aux suivvant j'ai le sablier et cela fat planter Excel.

Avez vous une idée ?

Merci

ci-dessous ma macro

Private Sub Worksheet_Change(ByVal Target As Range)
Dim temoin As Boolean
Dim Ref As Variant
If Not Intersect(Target, Range("g8:ep735")) Is Nothing And Target.Count = 1 And Not temoin Then 'test1
temoin = True
Target.Interior.ColorIndex = xlNone
For Each Ref In Sheets("MFC").Range("CouleurMFC1")
If UCase(Target.Value) = UCase(Ref.Value) Then 'test2

With Target
.RowHeight = Ref.RowHeight 'hauteur de ligne
.ColumnWidth = Ref.ColumnWidth 'largeur de colonne
.NumberFormat = Ref.NumberFormat 'format de nombre

.HorizontalAlignment = Ref.HorizontalAlignment 'alignement horizontal
.VerticalAlignment = Ref.VerticalAlignment 'alignement vertical
.WrapText = Ref.WrapText 'Retour à la ligne
.Orientation = Ref.Orientation 'Orientation du texte
.AddIndent = Ref.AddIndent 'Retrait
.IndentLevel = Ref.IndentLevel 'Niveau de retrait
.ShrinkToFit = Ref.ShrinkToFit 'Ajustement à la largeur de la cellule
.ReadingOrder = Ref.ReadingOrder 'sens de lecture
.MergeCells = Ref.MergeCells 'Cellules fusionnées

.Borders(xlDiagonalDown).LineStyle = Ref.Borders(xlDiagonalDown).LineStyle
.Borders(xlDiagonalUp).LineStyle = Ref.Borders(xlDiagonalUp).LineStyle
.Borders(xlEdgeLeft).LineStyle = Ref.Borders(xlEdgeLeft).LineStyle
.Borders(xlEdgeTop).LineStyle = Ref.Borders(xlEdgeTop).LineStyle
.Borders(xlEdgeBottom).LineStyle = Ref.Borders(xlEdgeBottom).LineStyle
.Borders(xlEdgeRight).LineStyle = Ref.Borders(xlEdgeRight).LineStyle
.Borders(xlInsideVertical).LineStyle = Ref.Borders(xlInsideVertical).LineStyle
.Borders(xlInsideHorizontal).LineStyle = Ref.Borders(xlInsideHorizontal).LineStyle

.Interior.ColorIndex = Ref.Interior.ColorIndex

With .Font
.Name = Ref.Font.Name 'police
.Size = Ref.Font.Size 'taille

.ColorIndex = Ref.Font.ColorIndex 'couleur de police
.Bold = Ref.Font.Bold 'gras ou non
.Italic = Ref.Font.Italic 'italique ou non
.Underline = Ref.Font.Underline 'souligné ou non
'.FontStyle = Ref.FontStyle
'.Strikethrough = Ref.Strikethrough
'.Superscript = Ref.Superscript
'.Subscript = Ref.Subscript
'.OutlineFont = Ref.OutlineFont
'.Shadow = Ref.Shadow
End With 'font

End With 'target
End If 'test2
Next Ref
temoin = False
End If 'test1
If Target.Address = "$A$1" Then
Set MaSélection = Nothing
Range("IV:IV").EntireRow.Hidden = False
If Target.Value <> "" Then
For i = 8 To 962
If Cells(i, 256).Value <> UCase(Target.Value) Then
If MaSélection Is Nothing Then
Set MaSélection = Cells(i, 256)
Else
Set MaSélection = Union(MaSélection, Cells(i, 256))
End If
End If
Next i
MaSélection.EntireRow.Hidden = True
Set MaSélection = Nothing
End If
End If
If Target.Address = "$A$2" Then
Set MaSélection = Nothing
Range("IT:IT").EntireRow.Hidden = False
If Target.Value <> "" Then
For i = 8 To 962
If Cells(i, 254).Value <> UCase(Target.Value) Then
If MaSélection Is Nothing Then
Set MaSélection = Cells(i, 254)
Else
Set MaSélection = Union(MaSélection, Cells(i, 254))
End If
End If
Next i
MaSélection.EntireRow.Hidden = True
Set MaSélection = Nothing
End If
End If
If Target.Address = "$A$3" Then
Set MaSélection = Nothing
Range("IV:IV").EntireRow.Hidden = False
If Target.Value <> "" Then
For i = 8 To 962
If Cells(i, 256).Value <> UCase(Target.Value) Then
If MaSélection Is Nothing Then
Set MaSélection = Cells(i, 256)
Else
Set MaSélection = Union(MaSélection, Cells(i, 256))
End If
End If
Next i
MaSélection.EntireRow.Hidden = True
Set MaSélection = Nothing
End If
End If
If Target.Address = "$A$4" Then
Set MaSélection = Nothing
Range("G1:ad1").EntireColumn.Hidden = False
If Target.Value <> "" Then
For i = 4 To 147
If Cells(1, i).Value <> UCase(Target.Value) Then
If MaSélection Is Nothing Then
Set MaSélection = Cells(1, i)
Else
Set MaSélection = Union(MaSélection, Cells(1, i))
End If
End If
Next i
MaSélection.EntireColumn.Hidden = True
Set MaSélection = Nothing
End If
End If
If Target.Address = "$A$5" Then
Set MaSélection = Nothing
Range("G2:ad2").EntireColumn.Hidden = False
If Target.Value <> "" Then
For i = 4 To 147
If Cells(2, i).Value <> UCase(Target.Value) Then
If MaSélection Is Nothing Then
Set MaSélection = Cells(2, i)
Else
Set MaSélection = Union(MaSélection, Cells(2, i))
End If
End If
Next i
MaSélection.EntireColumn.Hidden = True
Set MaSélection = Nothing
End If
End If
Application.ScreenUpdating = True
End Sub
 
Vote positif 0 Vote négatif
camarchepas

camarchepas

XLDnaute Barbatruc
Re : Copier Coller Cellule avec Validation en conservant la couleur

Bonjour à TOus ,

La mise en couleur cyan donne vraiment quelque chose d'illisible ..

C'est une procédure événementielle , donc dès qu'il y à à nouveau un changement , une nouvelle instance de cette procédure est lancée car l'on modifie la valeur de cellules.

Il faut donc désactiver les évenementielles pendant tout le temps de l'éxécution de la procédure.

en début de procédure


Application.EnableEvents = False


et en fin de procédure


Application.EnableEvents = True
 
Vote positif 0 Vote négatif
D

dirmon

XLDnaute Junior
Re : Copier Coller Cellule avec Validation en conservant la couleur

Bonjour à nouveau

Merci camarchepas mais j'ai toujours le même soucis.

Je te réécrit la macro modifiée

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Dim temoin As Boolean
Dim Ref As Variant
If Not Intersect(Target, Range("g8:ep735")) Is Nothing And Target.Count = 1 And Not temoin Then 'test1
temoin = True
Target.Interior.ColorIndex = xlNone
For Each Ref In Sheets("MFC").Range("CouleurMFC1")
If UCase(Target.Value) = UCase(Ref.Value) Then 'test2

With Target
.RowHeight = Ref.RowHeight 'hauteur de ligne
.ColumnWidth = Ref.ColumnWidth 'largeur de colonne
.NumberFormat = Ref.NumberFormat 'format de nombre

.HorizontalAlignment = Ref.HorizontalAlignment 'alignement horizontal
.VerticalAlignment = Ref.VerticalAlignment 'alignement vertical
.WrapText = Ref.WrapText 'Retour à la ligne
.Orientation = Ref.Orientation 'Orientation du texte
.AddIndent = Ref.AddIndent 'Retrait
.IndentLevel = Ref.IndentLevel 'Niveau de retrait
.ShrinkToFit = Ref.ShrinkToFit 'Ajustement à la largeur de la cellule
.ReadingOrder = Ref.ReadingOrder 'sens de lecture
.MergeCells = Ref.MergeCells 'Cellules fusionnées

.Borders(xlDiagonalDown).LineStyle = Ref.Borders(xlDiagonalDown).LineStyle
.Borders(xlDiagonalUp).LineStyle = Ref.Borders(xlDiagonalUp).LineStyle
.Borders(xlEdgeLeft).LineStyle = Ref.Borders(xlEdgeLeft).LineStyle
.Borders(xlEdgeTop).LineStyle = Ref.Borders(xlEdgeTop).LineStyle
.Borders(xlEdgeBottom).LineStyle = Ref.Borders(xlEdgeBottom).LineStyle
.Borders(xlEdgeRight).LineStyle = Ref.Borders(xlEdgeRight).LineStyle
.Borders(xlInsideVertical).LineStyle = Ref.Borders(xlInsideVertical).LineStyle
.Borders(xlInsideHorizontal).LineStyle = Ref.Borders(xlInsideHorizontal).LineStyle

.Interior.ColorIndex = Ref.Interior.ColorIndex

With .Font
.Name = Ref.Font.Name 'police
.Size = Ref.Font.Size 'taille

.ColorIndex = Ref.Font.ColorIndex 'couleur de police
.Bold = Ref.Font.Bold 'gras ou non
.Italic = Ref.Font.Italic 'italique ou non
.Underline = Ref.Font.Underline 'souligné ou non
'.FontStyle = Ref.FontStyle
'.Strikethrough = Ref.Strikethrough
'.Superscript = Ref.Superscript
'.Subscript = Ref.Subscript
'.OutlineFont = Ref.OutlineFont
'.Shadow = Ref.Shadow
End With 'font

End With 'target
End If 'test2
Next Ref
temoin = False
End If 'test1
If Target.Address = "$A$1" Then
Set MaSélection = Nothing
Range("IV:IV").EntireRow.Hidden = False
If Target.Value <> "" Then
For i = 8 To 962
If Cells(i, 256).Value <> UCase(Target.Value) Then
If MaSélection Is Nothing Then
Set MaSélection = Cells(i, 256)
Else
Set MaSélection = Union(MaSélection, Cells(i, 256))
End If
End If
Next i
MaSélection.EntireRow.Hidden = True
Set MaSélection = Nothing
End If
End If
If Target.Address = "$A$2" Then
Set MaSélection = Nothing
Range("IT:IT").EntireRow.Hidden = False
If Target.Value <> "" Then
For i = 8 To 962
If Cells(i, 254).Value <> UCase(Target.Value) Then
If MaSélection Is Nothing Then
Set MaSélection = Cells(i, 254)
Else
Set MaSélection = Union(MaSélection, Cells(i, 254))
End If
End If
Next i
MaSélection.EntireRow.Hidden = True
Set MaSélection = Nothing
End If
End If
If Target.Address = "$A$3" Then
Set MaSélection = Nothing
Range("IV:IV").EntireRow.Hidden = False
If Target.Value <> "" Then
For i = 8 To 962
If Cells(i, 256).Value <> UCase(Target.Value) Then
If MaSélection Is Nothing Then
Set MaSélection = Cells(i, 256)
Else
Set MaSélection = Union(MaSélection, Cells(i, 256))
End If
End If
Next i
MaSélection.EntireRow.Hidden = True
Set MaSélection = Nothing
End If
End If
If Target.Address = "$A$4" Then
Set MaSélection = Nothing
Range("G1:ad1").EntireColumn.Hidden = False
If Target.Value <> "" Then
For i = 4 To 147
If Cells(1, i).Value <> UCase(Target.Value) Then
If MaSélection Is Nothing Then
Set MaSélection = Cells(1, i)
Else
Set MaSélection = Union(MaSélection, Cells(1, i))
End If
End If
Next i
MaSélection.EntireColumn.Hidden = True
Set MaSélection = Nothing
End If
End If
If Target.Address = "$A$5" Then
Set MaSélection = Nothing
Range("G2:ad2").EntireColumn.Hidden = False
If Target.Value <> "" Then
For i = 4 To 147
If Cells(2, i).Value <> UCase(Target.Value) Then
If MaSélection Is Nothing Then
Set MaSélection = Cells(2, i)
Else
Set MaSélection = Union(MaSélection, Cells(2, i))
End If
End If
Next i
MaSélection.EntireColumn.Hidden = True
Set MaSélection = Nothing
End If
End If
Application.EnableEvents = True
End Sub



Merci
 
Vote positif 0 Vote négatif
camarchepas

camarchepas

XLDnaute Barbatruc
Re : Copier Coller Cellule avec Validation en conservant la couleur

Bonjour ,

Le fichier ne correspond pas au code :

Sheets("MFC").Range("CouleurMFC1") :' Pas de feuille MFC et pas de liste nommée CouleurMFC1.

Pourquoi utiliser une boucle pour rechercher la valeur dans la liste de référence, une recherche par .Find devrait être beaucoup plus efficace.

Pour le reste pas encore analysé car plutot indigeste.

Pourquoi ne pas mettre la mise en forme dans une routine spécifique ? , cela permet de gagner en lisibilité et forcement en temps de mise au point.

Ah oui Temoin ne sert à rien si il n'est pas une variable globale....

Code: 
Sub MiseEnforme(Modele As Range, Cible As Range)
      With Cible
       .RowHeight = Modele.RowHeight 'hauteur de ligne
       .ColumnWidth = Modele.ColumnWidth 'largeur de colonne
       .NumberFormat = Modele.NumberFormat 'format de nombre
       .HorizontalAlignment = Modele.HorizontalAlignment 'alignement horizontal
       .VerticalAlignment = Modele.VerticalAlignment 'alignement vertical
       .WrapText = Modele.WrapText 'Retour à la ligne
       .Orientation = Modele.Orientation 'Orientation du texte
       .AddIndent = Modele.AddIndent 'Retrait
       .IndentLevel = Modele.IndentLevel 'Niveau de retrait
       .ShrinkToFit = Modele.ShrinkToFit 'Ajustement à la largeur de la cellule
       .ReadingOrder = Modele.ReadingOrder 'sens de lecture
       .MergeCells = Modele.MergeCells 'Cellules fusionnées
       .Borders(xlDiagonalDown).LineStyle = Modele.Borders(xlDiagonalDown).LineStyle
       .Borders(xlDiagonalUp).LineStyle = Modele.Borders(xlDiagonalUp).LineStyle
       .Borders(xlEdgeLeft).LineStyle = Modele.Borders(xlEdgeLeft).LineStyle
       .Borders(xlEdgeTop).LineStyle = Modele.Borders(xlEdgeTop).LineStyle
       .Borders(xlEdgeBottom).LineStyle = Modele.Borders(xlEdgeBottom).LineStyle
       .Borders(xlEdgeRight).LineStyle = Modele.Borders(xlEdgeRight).LineStyle
       .Borders(xlInsideVertical).LineStyle = Modele.Borders(xlInsideVertical).LineStyle
       .Borders(xlInsideHorizontal).LineStyle = Modele.Borders(xlInsideHorizontal).LineStyle
       .Interior.ColorIndex = Modele.Interior.ColorIndex
       With .Font
        .Name = Modele.Font.Name 'police
        .Size = Modele.Font.Size 'taille
        .ColorIndex = Modele.Font.ColorIndex 'couleur de police
        .Bold = Modele.Font.Bold 'gras ou non
        .Italic = Modele.Font.Italic 'italique ou non
        .Underline = Ref.Font.Underline 'souligné ou non
        '.FontStyle = Modele.FontStyle
        '.Strikethrough = Modele.Strikethrough
        '.Superscript = Modele.Superscript
        '.Subscript = Modele.Subscript
        '.OutlineFont = Modele.OutlineFont
        '.Shadow = Modele.Shadow
       End With 'font
      End With 'target
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

Dim Ref As Range
If Not Intersect(Target, Range("g8:ep735")) Is Nothing And Target.Count = 1 Then 'test1
   Application.EnableEvents = False
   Target.Interior.ColorIndex = xlNone
   
   Set Ref = Range("Couleur").Find(Target, lookat:=xlWhole)
     If Not Ref Is Nothing Then
       MiseEnforme Ref, Target
       Application.EnableEvents = true
       Exit Sub
     End If 'test1

'Suite

end if
end sub
 
Vote positif 0 Vote négatif
D

dirmon

XLDnaute Junior
Re : Copier Coller Cellule avec Validation en conservant la couleur

Bonsoir

Merci camarchepas pour ton aide

J'ai mis ta macro à la place de la mienne et la fin de la procédure ne fonctionne pas.

Effectivement le fichier joint initialement a été joint pour être téléchargé.

Tu peux trouver le fichier origine ici :

Excel Downloads - Planning Effectif 2014

Le reste de la procédure permet en sélectionnant les cases de A1 à A5 de masquer ou afficher des lignes ou colonnes.


Merci pour ton aide
 
Vote positif 0 Vote négatif
camarchepas

camarchepas

XLDnaute Barbatruc
Re : Copier Coller Cellule avec Validation en conservant la couleur

Re ,

Sur ton fichier original , cela ne fonctionne pas non plus ...

Il faut revoir la déclaration des listes nommées en doubles .

Ensuite cela doit fonctionner .

J'ai fais un test simple sur 2 exemples dans un classeur test et cela fonctionne.

A oui , la déclaration des variables c'est quand même bien utile.
 
Vote positif 0 Vote négatif
camarchepas

camarchepas

XLDnaute Barbatruc
Re : Copier Coller Cellule avec Validation en conservant la couleur

Bonsoir ,

Repostes un fichier avec les champs nommés corrects ou si ccela est trop compliqué pour toi ,

N'utilises pas les champs nommés et fait tout en vba , là aussi republies un fichier débarassé des champs nommés dans ce cas .
 
Vote positif 0 Vote négatif

Discussions similaires

D
  • Question
XL 2010 Valoriser cellule par clic
Réponses
4
Affichages
221
fanch55
fanch55
P
  • Résolu(e)
Microsoft 365 Copier coller une cellule avant qu'elle ne soit modifiée par Sub Worksheet_Change(ByVal Target As Range)
2
Réponses
19
Affichages
704
pat66
P
S
  • Question
Microsoft 365 VBA pour copier une une des données d'une ligne à une autre
Réponses
2
Affichages
126
crocrocro
C
halecs93
  • Résolu(e)
XL 2016 Indice n'appartient pas à la sélection : HELP !!!!
2
Réponses
21
Affichages
536
halecs93
halecs93
M
  • Question
XL 2013 changement de couleur de police qd cellule modifiée
Réponses
10
Affichages
288
michel.dupont
M
M
  • Question
Microsoft 365 Copier / coller avec mise en forme VBA
Réponses
0
Affichages
144
marie3107
M
F
  • Résolu(e)
XL 2021 fermeture du classeur après apple d'un userform d'un autre classeur ouvert
Réponses
2
Affichages
95
farid
F
J
  • Question
XL 2019 recuperer plage de cellule sur feuille differente
Réponses
2
Affichages
347
juju91
J
A
  • Question
Insérer un copier / coller
Réponses
0
Affichages
182
aziz
A
U
  • Question
Autres [RÉSOLU] Faire afficher ligne sur tout le classeur par double clic et la faire maquer à l’enregistrement
Réponses
11
Affichages
408
un internaute
U

Membres actuellement en ligne

Aucun membre en ligne actuellement.
1 membres et 34 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 206
Messages
2 086 219
Membres
103 158
dernier inscrit
laufin