Changer de couleur Résolu

Question

Bonjour a toutes et tous, Forum bonjour Configuration: Windows 7 / Internet Explorer 9.0 VBA excel 2007 Je souhaiterai apporter une petite modification au petit code ci-dessous afin d'améliorer la visibilité des valeurs qui s'affichent en VERT en colonne (Q). Dans la plage Q2 à Q26 des valeurs s'affichent avec une barre GRISE qui monte et descends dans cette plage servant de repère. Je voudrais svp que la couleur des valeurs s'affichent en suivant la barre GRISE avec valeurs en BLEU dans la barre de repère. J'ai essayer mais bien sur ca marche pas Merci de votre aide et de votre temps Bonne fin d'après midi a tous Cdlt Ray PS: le code fonctionne '*** RECOPIE LA VALEUR DANS LA PLAGE LIGNE(E20:P20) MOIS PAR MOISPrivate Sub Worksheet_Calculate() Dim C As Long, R As Long C = Month(Now) + 4 R = [Z1].Value: If R < 2 Then R = 1'*** Ligne Q2:Q26 Colonne 17(Q) With Cells(R, 17).Interior .ColorIndex = 15 'Affiche la barre repère Gris clair If Cells(20, C).Text <> Cells(R, 17).Text Then Application.EnableEvents = False R = R + 1: If R > 26 Then R = 2 [Z1].Value = R Cells(R, 17).Value = Cells(20, C).Value .ColorIndex = xlNone Application.EnableEvents = True End If End WithEnd Sub

Mike-31 · Answer

Bonjour,

Pas tout compris mais  complète le code comme cela voir si c'est ce que tu cherches

With Cells(R, 17)
.Interior.ColorIndex = 15
.Font.ColorIndex = 5

dudulleray · Answer

Salut Mike-31 Merci pour ta rapide réponse, mais ca marche pas comme voulu mais ca plante pas Entre temps, j'ai fait le code ci-dessous, j'obtiens bien ce que je souhaite Mais le code n'ai pas beau, on peut modifier c'est clair si tu crois svp pouvoir m'allèger ca, je veux bien car moi je n'ai pas pu faire mieux. Merci a toi, je te souhaite la bonne soirée Cordialement Raymond '*** RECOPIE LA VALEUR DANS LA PLAGE LIGNE(E20:P20) MOIS PAR MOISPrivate Sub Worksheet_Calculate() Dim C As Long, R As Long C = Month(Now) + 4 R = [Z1].Value: If R < 2 Then R = 1'*** Ligne Q2:Q26 Colonne 17(Q)With Cells(R, 17).Font .ColorIndex = 4 'VertEnd With With Cells(R, 17).Interior .ColorIndex = 15 'Gris Affiche la barre repère Gris clair If Cells(20, C).Text <> Cells(R, 17).Text Then Application.EnableEvents = False R = R + 1: If R > 26 Then R = 2 [Z1].Value = R Cells(R, 17).Value = Cells(20, C).Value .ColorIndex = xlNone Application.EnableEvents = True End If End With With Cells(R, 17).Font .ColorIndex = 5 'BleueEnd WithEnd Sub

Mike-31 · Answer

Re,

pourquoi utilises tu cette syntaxe qui démarre le code à chaque saisie

Private Sub Worksheet_Calculate

de même pourquoi deux With

With Cells(R, 17).Font
     .ColorIndex = 4                'Vert
End With
 
   With Cells(R, 17).Interior
          .ColorIndex = 15 


explique ce que tu veux faire à partir d'une plage exemple si je saisis une valeur entre Q2 et Q18 je souhaiterais etc ...

dudulleray · Answer

Salut Mike

Merci pour ta réponse voila j'explique pour le mieux.

(1) But améliorer svp le code, car ce que j'ai fait c'est du bricolage.

je fais un suivi d'une valeur se trouvant dans la ligne 20 et en fonction du mois en cours a chaque fois que la valeur change, la valeur est copier automatiquement dans la colonne Q de Q2 à Q26

Voir svp photo ci jointe   le lien ci-dessous

http://www.cjoint.com/?0Joje1nnoyk

la colonne Q est au format monétaire  Rouge quand valeur négative et Vert positif

pour mieux repérer, j'ai voulu une barre grise avec la valeur changante en bleue.

la barre grise et la valeur bleue s'affiche en Q2 et au fur et a mesure que la valeur change ca descends jusqu'a Q26 puis remonte en Q2 et ainsi de suite.

Sans effacer la colonne Q (c'est volontaire)

Merci pour ton aide je te souhaite un bon début de semaine

Cordialement Raymond

Mike-31 · Answer

Re,

Si je comprends bien, la valeur que tu saisis en N20 doit s'inscrire à la suite colonne Q entre Q2 et Q26
lorsqu'on change de mois exemple le 1er novembre les valeurs N20 se réinscrivent à la suite à partir de la cellule Q2
la dernière cellule renseignée en Q se colorise en gris et police bleu

c'est cela

dudulleray · Answer

Salut Mike

oui tu a bien compris, c'est bien ca 

SAUF que pour novembre 2013 c'est O20
et pour décembre 2013 ca sera P20

puis pour Janvier 2014 ca sera E20 et ainsi de suite Mais toujours la ligne 20

si besoin je suis a ta dispo

a plus tard 

Raymond

Mike-31 · Answer

Ok bien vu, je te regarde un code dans l'aprem

Mike-31 · Answer

Re,

vite fait, clic droit sur ton onglet de feuille et colle ce code à la place de l'ancien ou des anciens, ce code gère la plage de saisie E20 à P20
transcrit la dernière saisie en colonne Q avec mise en forme mais pour automatiser le changement de mois nécessite une colonne dans mon exemple la R qui peut être masquée.
j'ai rajouté une boite de dialogue pour confirmer les changement de mois et éviter les erreurs



Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Not Intersect(Target, [E20:P20]) Is Nothing Then
If Target = "" Then Exit Sub
If Month(Target.Offset(-19, 0)) < [R1] Or Month(Target.Offset(-19, 0)) > [R1] Then
If MsgBox("Etes-vous certain de vouloir enregistrer les données du mois de " & _
Format(Target.Offset(-19, 0), "mmmm"), vbYesNo, "Demande de confirmation") = vbYes Then
[R1:R26].ClearContents
[Q2:Q26].Interior.ColorIndex = xlNone
[Q2:Q26].Font.ColorIndex = xlAutomatic
[R1] = Month(Target.Offset(-19, 0))
[R28].End(xlUp)(-1, 0).Interior.ColorIndex = xlNone
[R28].End(xlUp)(-1, 0).Font.ColorIndex = xlAutomatic
[R28].End(xlUp)(2, 1) = Range("R28").End(xlUp) + 1 'Target
[R28].End(xlUp)(1, 0) = Target
[R28].End(xlUp)(1, 0).Interior.ColorIndex = 15
[R28].End(xlUp)(1, 0).Font.ColorIndex = 4
Else
Exit Sub
End If
Else
[R1] = Month(Target.Offset(-19, 0))
[R28].End(xlUp)(1, 0).Interior.ColorIndex = xlNone
[R28].End(xlUp)(1, 0).Font.ColorIndex = xlAutomatic
[R28].End(xlUp)(2, 1) = Range("R28").End(xlUp) + 1 'Target
[R28].End(xlUp)(1, 0) = Target
[R28].End(xlUp)(1, 0).Interior.ColorIndex = 15
[R28].End(xlUp)(1, 0).Font.ColorIndex = 4
End If
End If
End Sub


 
A+
Mike-31

Une période d'échec est un moment rêvé pour semer les graines du savoir.

dudulleray · Answer

Re salut Mike

Merci pour le code 

j'ai suivi tes conseils et ca ne plante pas déja ca LOL

(1) par contre rien ne se copie dans la colonne Q ----> (Q2:Q26)

(2) j'ai simuler le mois de novembre et le changement de mois se passe bien

Pourquoi tu veux tout re-gérer ca fonctionne bien et ca va se compliquer avec l'userform et ce n'ai pas tout

t'expliquer le fonctionnement du programme ne va pas etre chose facile

c'est un peu une usine a gaz LOL cependant il fonctionne bien quand mème.

--------------------

c'est juste que je souhaitai optimiser l'affichage du repère gris et la valeur en bleue

qui suit le repère car le code que j'ai fait pour gérer ca n'ai pas terrible.

a plus tard et merci je regarde le code au cas je trouverai

bye a plus tard

Ray

Mike-31 · Answer

Re,

C'est peut être parce que j'ai également automatisé ton calendrier de sorte de saisir en E1 le 1/1/et l'année et les en tête s'automatisent ce qui également permet à Excel de reconnaitre les mois

exemple sur ce fichier qu'il est encore possible d'améliorer si tu le souhaites, comme coloriser l'en-tête de saisie

https://www.cjoint.com/?CJorTXHFW9U
 
A+
Mike-31

Une période d'échec est un moment rêvé pour semer les graines du savoir.

dudulleray · Answer

Salut Mike Merci beaucoup pour le fichier, et pour ton aide mais je ne veux pas remodifier mon programme il fonctionne très bien tout est automatiser je souhaite svp juste savoir si il est possible d'améliorer le code ci dessous c'est un petit plus que j'ai voulu apporter au programme. j'ai sans doute mal formuler ma demande, j'en suis bien désolé. Bien cordialement Ray Private Sub Worksheet_Calculate() Dim C As Long, R As Long C = Month(Now) + 4 R = [Z1].Value: If R < 2 Then R = 1 With Cells(R, 17).Font .ColorIndex = 10 'Vert foncé End With With Cells(R, 17).Interior .ColorIndex = 15 'Gris Affiche la barre repère Gris clair If Cells(20, C).Text <> Cells(R, 17).Text Then Application.EnableEvents = False R = R + 1: If R > 26 Then R = 2 [Z1].Value = R Cells(R, 17).Value = Cells(20, C).Value .ColorIndex = xlNone Application.EnableEvents = True End If End With With Cells(R, 17).Font .ColorIndex = 5 'Bleu End WithEnd Sub

Mike-31 · Answer

Re, Si ton code te convient, tu peux supprimer deux boucle With Private Sub Worksheet_Calculate() Dim C As Long, R As Long C = Month(Now) + 4 R = [Z1].Value: If R < 2 Then R = 1 Cells(R, 17).Font.ColorIndex = 10 With Cells(R, 17).Interior .ColorIndex = 15 'Gris Affiche la barre repère Gris clair If Cells(20, C).Text <> Cells(R, 17).Text Then Application.EnableEvents = False R = R + 1: If R > 26 Then R = 2 [Z1].Value = R Cells(R, 17).Value = Cells(20, C).Value .ColorIndex = xlNone Application.EnableEvents = True End If End With Cells(R, 17).Font.ColorIndex = 5 End Sub

dudulleray · Answer

Bonjour Mike,

Merci beaucoup ca marche très bien, tu as optimiser le code chose que je n'ai pas su faire aussi bien

Bon ca marchai quand mème, mais le superflu n'étant pas obligatoire alors autant dans la mesure du possible optimiser

donc merci et désolé de t'avoir fait perdre du temps mais c'est tout de mème gentil a toi d'avoir voulu faire du mieux dans mon programme

Si tu veux dans mon programme, j'ai deux autres petits bout de codes simple que l'on pourrai optimiser si tu veux bien regarder.

Dit moi si Ok sinon c'est pas grave

Je te remercie de ta patience et pour ton aide.

A plus tard 

Bien cordialement Raymond

Mike-31 · Answer

Re,

envoie toujours après on verra ce que l'on peut faire

dudulleray · Answer

Bonjour Mike

Merci de bien vouloir regarder

voila Quand je clic dans la cellule Q27 ca déclenche la macro ci dessous

mais ca marche pas comme je souhaiterai.

Car avec ce code j'ai bien le message de la Msgbox mais quand je clic sur la croix de Msgbox 

ca efface bien la colonne Q2:Q26
et ca efface également quand je quitte la Msgbox

je voudrais svp pouvoir avoir le choix Effacer la colonne Q2:Q26 par confirmation OUI ou NON

et si possible éviter une Msgbox sinon je ferai avec
et optimiser le code par la mème occasion

Donc effacer manuellement le fond et les valeurs de la colonne Q

Merci a toi 

a plus tard Mike

Cdlt Ray

'*** BOUTON POUR EFFACER LA COLONNE(Q)SANS SUPPRIMER LES FORMULES DES CELLULESSub EffaceCellule()  MsgBox "Etes vous sur de vouloir effacer la colonne"            [Q2:Q26].SpecialCells(xlCellTypeConstants, 23).ClearContents  Range("Q2:Q26").Interior.ColorIndex = xlNoneEnd Sub

Mike-31 · Answer

Re,

"BOUTON POUR EFFACER LA COLONNE(Q)SANS SUPPRIMER LES FORMULES DES CELLULES"

ça ce n'est pas possible, avec clearcontents le contenu des cellules est supprimé ou il faut intervenir en amont des formules de sorte que les formules de la colonne Q soit à zéro ou vide
le mieux serait d'avoir un exemple de ton fichier que tu peux joindre avec ce lien

https://www.cjoint.com/ 

clic sur le lien/parcourir pour sélectionner le fichier/créer le lien reste plus qu'à coller le lien généré dans ta réponse

dudulleray · Answer

RE

Bien vu a ton tour, j'ai omis de te dire qu'il ni a pas de formule dans la colonne Q

juste au format monétaire Rouge quand valeur négative, Vert valeur positive

et Bleu pour mieux repérer la valeur changeante

Donc pas de formule 


Merci Mike

A plus tard  Ray

Mike-31 · Answer

Re,

essaye comme cela

Sub EffaceCellule()
    If MsgBox("Etes-vous certain de vouloir effacer les données de la colonne Q ", vbYesNo, "Demande de confirmation") = vbYes Then
    [Q2:Q26].ClearContents
    [Q2:Q26].Interior.ColorIndex = xlNone
    Else
    Exit Sub
    End If
End Sub

dudulleray · Answer

Re

Ok nickel ca marche comme souhaiter, Merci beaucoup Mike


Pour le fichier, je peux te l'envoyer mais avant il faut que je cache certaines infos persos

ca demande un peu de temps

dit moi et je te le prépare

Ray

Mike-31 · Answer

Re,

non ce n'est pas la peine si le code te satisfait. 

Si tu n'as plus de question, passe le statut de la discussion en résolu ou confirme le moi, je le ferai pour toi

dudulleray · Answer

Re Mike

j'avais une autre question, mais il que je revois ca avant

cela fera partie d'un autre sujet plus tard

je vais passer en "résolu" 

Donc je te remercie beaucoup de m'avoir aider c'est gentil a toi

mon programme a meilleur allure

Je te souhaite un excellente journée avec tous pleins de sincères remerciements

Bye bye Mike 

Cordialement Raymond

Mike-31 · Answer

Re,

Pour ton nouveau sujet, une fois déposé envoi moi un petit message privé pour attirer mon attention, si je peux t'aider ce sera avec plaisir

Changer de couleur - Page 2

Discussions similaires

Newsletters