Copier Coller Cellule avec Validation en conservant la couleur

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
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

Trier par date Trier par votes
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
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
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
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
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
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
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
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
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

D
  • Question Question
Microsoft 365 VBA copier cellule, conserver la copie tout en effaçant contenu
2 3
Réponses
33
Affichages
2 K
fanch55
fanch55
S
  • Résolu(e)
Microsoft 365 Déclenchement macro en série suite à cellule fusionnées
Réponses
3
Affichages
452
spike29
S
Nicolas JACQUIN
  • Question Question
XL 2019 Gérer la descente d'une cellule colorer selon un timer
2 3 4
Réponses
56
Affichages
2 K
Rheeem
R
I
  • Résolu(e)
Microsoft 365 Copier-coller dans une plage avec des cellules masquées
Réponses
6
Affichages
553
sylvanu
sylvanu
E
  • Résolu(e)
Microsoft 365 Copier Coller selon condition
Réponses
5
Affichages
373
TooFatBoy
TooFatBoy
X
  • Question Question
XL 2021 Génération word à partir d'excel en gardant le format source
Réponses
8
Affichages
245
xlym
X
C
Excel : Fusionner des cellules en conservant le contenu et la police des cellules à fusionner
Réponses
5
Affichages
655
crocrocro
C
Sellig
  • Résolu(e)
XL 2019 Sélection zone avec la souris et copier puis Sélection zone avec la souris et coller
Réponses
9
Affichages
704
Sellig
Sellig
C
  • Question Question
XL 2016 VBA - Mettre en Indice une partie du contenu d'une cellule : problème avec la propriété Font.Subscript
Réponses
2
Affichages
479
crocrocro
C
F
  • Résolu(e)
Microsoft 365 copier coller des colonnes en fonction de la valeur d'une cellule
Réponses
8
Affichages
911
loloboc
L
M
  • Question Question
Microsoft 365 Copier / coller avec mise en forme VBA
Réponses
0
Affichages
876
marie3107
M
D
  • Question Question
XL 2010 Valoriser cellule par clic
Réponses
4
Affichages
590
fanch55
fanch55
piga25
  • Résolu(e)
XL 2016 Mettre la même couleur de la dernière cellule colorée
Réponses
5
Affichages
463
TooFatBoy
TooFatBoy
G
  • Résolu(e)
XL 2013 copier coller valeur d'une colonne dynamique
Réponses
13
Affichages
805
gwenn49
G
Jojo973
  • Question Question
Microsoft 365 Trouver et attribuer une plage de cellule en fonction de la cellule active
Réponses
6
Affichages
564
Jojo973
Jojo973
A
  • Question Question
Insérer un copier / coller
Réponses
0
Affichages
381
aziz
A
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
1 K
pat66
P
M
  • Question Question
XL 2013 changement de couleur de police qd cellule modifiée
Réponses
10
Affichages
670
michel.dupont
M
S
  • Question Question
Microsoft 365 VBA pour copier une une des données d'une ligne à une autre
Réponses
3
Affichages
937
salma_hayek
S
J
  • Question Question
XL 2019 recuperer plage de cellule sur feuille differente
Réponses
2
Affichages
671
juju91
J
Retour