Couleurs automatiques en fonction d'une autre feuille

Bonjour,

Sur le fichier joint, vous trouverez mon projet de planning.

L'idée est de pouvoir, une fois le planning remplie (feuille n°1), imprimer automatiquement sur la feuille n°2 la semaine choisie (en cellule C1).

J'ai pu, à l'aide de fonctions Index et Equiv retrouver les valeurs de mon planning automatiquement. Le problème est que j'aimerais que les couleurs des cellules suivent aussi. Sans passer par du VBA de préférence (mes utilisateurs n'ont pas le reflex de cliquer sur "activer le contenu"... c'est des gars du bâtiment !)

Une idée?

Je vous remercie par avance pour votre soutiens.

A.T. Dodu'x

Bonjour,

Seulement la couleur de fond de la cellule, ou également pour le texte (Font.Name, Font.Size, Font.Color) ?

Vous pourriez aussi utiliser l'événement "Private Sub Worksheet_Activate()" de l'onglet "Impression semaine"

pour appliquer les formats désirés.

Bonjour sabV,

Le fond et le texte si possible ! J'avais pensé a un worksheet activate ou un worksheey change byval sur la cellule C1, mais je voulais surtour savoir si je pouvais éviter le VBA. Si je n'ai pas le choix je vais faire avec

Bonjour Dodu'x,

Voici le transfert des formats,

j'ai pris en compte que les plages sont

OP1:OP15 = 4 - 17 et 19

op16:op30 = 20 - 34

op31:op45 = 35 - 49

op46:op59 = 50 - 64

et que l'onglet "Impression semaine" est toujours au même format

Sub Macro1()
Dim sh1, sh2
Dim plg1a As String, plg1b As String, plg2 As String, plg3 As String, plg4 As String
Set sh1 = Sheets("Planning")
Set sh2 = Sheets("Impression semaine")
rw = Application.Match(sh2.Range("C1"), sh1.Range("B:B"), 0)
With sh1
    plg1a = .Range(.Cells(rw, 4), .Cells(rw + 5, 17)).Address
    plg1b = .Range(.Cells(rw, 4), .Cells(rw + 5, 19)).Address
    plg2 = .Range(.Cells(rw, 20), .Cells(rw + 5, 34)).Address
    plg3 = .Range(.Cells(rw, 35), .Cells(rw + 5, 49)).Address
    plg4 = .Range(.Cells(rw, 50), .Cells(rw + 5, 64)).Address
End With

sh1.Range(plg1a).Copy
sh2.Cells(4, 3).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

sh1.Range(plg1b).Copy
sh2.Cells(4, 17).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

sh1.Range(plg2).Copy
sh2.Cells(11, 3).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

sh1.Range(plg3).Copy
sh2.Cells(18, 3).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

sh1.Range(plg4).Copy
sh2.Cells(25, 3).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Application.CutCopyMode = False
Range("A1").Select
End Sub

Super tu gères

Je test ça courant semaine prochaine et te tiens informé !

Merci beaucoup en tout cas et bon weekend de paques

merci du retour Dodu'x,

bon w.e à toi également,

ps/ petite correction à la macro

j'avais oublié la déclaration suivante

Dim rw As Long