Code VBA couleur de date a échéance

Le 08/05/2023 à 21:41

Bonjour,

Je recherche un code vba (pas une mfc )

sur ma feuille "en service" j ai un tableau (je ne connais pas le nom de ce type de tableau ,une ligne bleu clair une ligne bleu foncee)la colonne s'appelle (Dernier contrôle)

en colone E mon userform inscrit une date

je cherche un code pour que mon tableau affiche a l ouverture de l onglet

en rouge si cette date est périmé par rapport a la date du jour

en orange si elle périme dans 2 mois ou moins

et en vert si il reste jusqu a 10 mois avant sont therme

Si besoin pour la formule il est possible de creer une colone en F avec le nombre de jour restant avant d arriver a la date en colone E mais les couleurs devront aussi y etre attribuées

merci pour votre aide

Le 09/05/2023 à 11:29

Bonjour,

Tu peux adapter ça a ton fichier :

28changement-couleur-suivant-date-geof.xlsm (22.70 Ko)

PS : Ton tableau est surement un tableau structuré (Les tableaux structurés)

A+

Le 09/05/2023 à 21:03

Merci beaucoup super boulot

j ai modifié mes colonnes et ca fonctionne parfaitement

je me demandais si il existe un code pour récupérer les valeur des ligne de mon tableau ou apparaît la couleur rouge dans ma colone des dates "Dernier Contrôle"

et coller ces lignes dans une feuille nommé "A traité"

apres je l adapte pour le orange sur une autre feuille

Le 09/05/2023 à 23:03

Alors oui, on peut mais on va pas le faire. Autre proposition :

Dans le cas "controler la couleur rouge" on cherche "Liste.interior.color = rouge"
Dans le cas "controler si la date est périmé" on cherche "Liste < DateJour"

Et vu que l'on met la couleur grace a la date, on va juste rajouter une étape au moment ou la couleur est mise.
(+ suppressions des anciennes donnée pour une actualisation a chaque fois que "en service" est activé.)

11changement-couleur-suivant-date-geof2.xlsm (27.42 Ko)

Je te laisse le Orange

A+

Le 10/05/2023 à 14:15

Merci pour ce super code j'ai voulu l’adapter mais je n'y arrive pas

j'ai renommé le code avec mes noms de tableau et voulu modifier le réglage des dates en couleur sans succés

Pour recapituler

-Mon tableau bleu est celui de base ou je rentre mes info

dans la colonne "Derniere vérification" il y as la dernière date de ctrl il faut que les dates des ctrl effectué:

il y a moins de 10 mois reste verte

entre il y a 10 mois et 1 an reste orange (reste 2 mois ou moins avant de passer en rouge)

Et celle qui ont plus d'1 an rouge

Sur ma feuille Accueil il y a 2 tableau

Tableau rouge qui récupère la ligne complète ou la date est en rouge dans mon tableau bleu

Tableau orange pareil pour la dates en orange

Actuellement je n'ai que que 5 ou 6 colonnes dans mon tableau bleu mais il va évoluer il me faut donc récupérer la ligne complète

Private Sub Worksheet_Activate()'Lien couleurs => https://www.excel-pratique.com/fr/vba/liste-couleurs-rgbDim DateJour As DateDateJour = Format(Date, "dd/mm/yy")Noir = RGB(0, 0, 0)Rouge = RGB(255, 0, 0)Orange = RGB(255, 192, 32)Vert = RGB(0, 255, 0)Set TAB_BLEU = Sheets("En service").ListObjects("T_Bleu")Set TAB_ROUGE = Sheets("Accueil").ListObjects("T_Rouge")Set TAB_ORANGE = Sheets("Accueil").ListObjects("T_Orange")'RazTAB_BLEU.ListColumns("Derniere vérification").DataBodyRange.Interior.Pattern = xlNoneIf Not TAB_ROUGE.DataBodyRange Is Nothing Then TAB_ROUGE.DataBodyRange.DeleteIf Not TAB_ORANGE.DataBodyRange Is Nothing Then TAB_ROUGE.DataBodyRange.DeleteSet ListDate = TAB_BLEU.ListColumns("Derniere vérification")Set ListPerime = TAB_ROUGE.ListColumns("Derniere vérification")Set ListPerime = TAB_ORANGE.ListColumns("Derniere vérification")For Each Liste In ListDate.DataBodyRange If Liste < DateAdd("m", -10, DateJour) Then 'met en orange au dela de 10 mois Liste.Interior.Color = Orange 'cherche date orange TAB_ORANGE.ListRows.Add ListPerime.DataBodyRange.Rows(ListPerime.DataBodyRange.Rows.Count) = Liste '.Rows ListPerime.DataBodyRange.Rows(ListPerime.DataBodyRange.Rows.Count).Offset(0, -1) = Liste.Offset(0, -1) ListPerime.DataBodyRange.Rows(ListPerime.DataBodyRange.Rows.Count).Offset(0, -2) = Liste.Offset(0, -2) End IfNext ListeFor Each Liste In ListDate.DataBodyRangeIf Liste < DateAdd("m", -12, DateJour) Then 'met en rouge au dela de 12 mois Liste.Interior.Color = Rouge 'cherche date rouge TAB_ROUGE.ListRows.Add ListPerime.DataBodyRange.Rows(ListPerime.DataBodyRange.Rows.Count) = Liste '.Rows ListPerime.DataBodyRange.Rows(ListPerime.DataBodyRange.Rows.Count).Offset(0, -1) = Liste.Offset(0, -1) ListPerime.DataBodyRange.Rows(ListPerime.DataBodyRange.Rows.Count).Offset(0, -2) = Liste.Offset(0, -2) End If Next ListeEnd Sub

Le 10/05/2023 à 14:16
Private Sub Worksheet_Activate()
'Lien couleurs => https://www.excel-pratique.com/fr/vba/liste-couleurs-rgb

Dim DateJour As Date
DateJour = Format(Date, "dd/mm/yy")

Noir = RGB(0, 0, 0)
Rouge = RGB(255, 0, 0)
Orange = RGB(255, 192, 32)
Vert = RGB(0, 255, 0)

Set TAB_BLEU = Sheets("En service").ListObjects("T_Bleu")
Set TAB_ROUGE = Sheets("Accueil").ListObjects("T_Rouge")
Set TAB_ORANGE = Sheets("Accueil").ListObjects("T_Orange")

'Raz
TAB_BLEU.ListColumns("Derniere vérification").DataBodyRange.Interior.Pattern = xlNone
If Not TAB_ROUGE.DataBodyRange Is Nothing Then TAB_ROUGE.DataBodyRange.Delete
If Not TAB_ORANGE.DataBodyRange Is Nothing Then TAB_ROUGE.DataBodyRange.Delete

Set ListDate = TAB_BLEU.ListColumns("Derniere vérification")
Set ListPerime = TAB_ROUGE.ListColumns("Derniere vérification")
Set ListPerime = TAB_ORANGE.ListColumns("Derniere vérification")

For Each Liste In ListDate.DataBodyRange
   If Liste < DateAdd("m", -10, DateJour) Then 'met en orange au dela de 10 mois
        Liste.Interior.Color = Orange 'cherche date orange
        TAB_ORANGE.ListRows.Add
        ListPerime.DataBodyRange.Rows(ListPerime.DataBodyRange.Rows.Count) = Liste '.Rows
        ListPerime.DataBodyRange.Rows(ListPerime.DataBodyRange.Rows.Count).Offset(0, -1) = Liste.Offset(0, -1)
        ListPerime.DataBodyRange.Rows(ListPerime.DataBodyRange.Rows.Count).Offset(0, -2) = Liste.Offset(0, -2)

    End If
Next Liste
For Each Liste In ListDate.DataBodyRange
If Liste < DateAdd("m", -12, DateJour) Then 'met en rouge au dela de 12 mois
        Liste.Interior.Color = Rouge 'cherche date rouge
        TAB_ROUGE.ListRows.Add
        ListPerime.DataBodyRange.Rows(ListPerime.DataBodyRange.Rows.Count) = Liste '.Rows
        ListPerime.DataBodyRange.Rows(ListPerime.DataBodyRange.Rows.Count).Offset(0, -1) = Liste.Offset(0, -1)
        ListPerime.DataBodyRange.Rows(ListPerime.DataBodyRange.Rows.Count).Offset(0, -2) = Liste.Offset(0, -2)

    End If
    Next Liste
End Sub
Le 10/05/2023 à 16:22

J'ai vu surtout 2 boulettes :

TAB_ROUGE a la place de TAB_ORANGE
'qui n'etait pas changé dans le raz

et

Set ListPerime = TAB_ROUGE.ListColumns("Derniere vérification")
Set ListPerime = TAB_ORANGE.ListColumns("Derniere vérification")
'Tu ne peux pas avoir 2 ListPerime avec le meme nom.

Set ListPerimeR = TAB_ROUGE.ListColumns("Derniere vérification")
Set ListPerimeO = TAB_ORANGE.ListColumns("Derniere vérification")

J'ai aussi modifié le bouron RAZ et remis la couleur verte disparu.

8changement-couleur-suivant-date-geof3.xlsm (29.17 Ko)

J'ai rajouté au classement du orange que les elements rouge ne vont pas etre dans le tableau orange.
A toi de voir les "<" / ">" / "<=" / ">=" si tu veux etre au jour près.

Pour avoir la ligne entiere, tu peux jouer avec les ".Offset(0, ...)"

A+

Le 10/05/2023 à 22:12

MAGNIFIQUE vraiment merci

j essaie de décaler la copie es qu il faut écrire autant de ligne que de colonne ou existe t il une fonction all pour sélectionner toute les colonne a droite et a gauche ?

ListPerimeO.DataBodyRange.Rows(ListPerimeO.DataBodyRange.Rows.Count).Offset(0, -4) = Liste.Offset(0, -4)
        ListPerimeO.DataBodyRange.Rows(ListPerimeO.DataBodyRange.Rows.Count).Offset(0, 5) = Liste.Offset(0, 5)
ListPerimeO.DataBodyRange.Rows(ListPerimeO.DataBodyRange.Rows.Count).Offset(0, 6) = Liste.Offset(0, 6)
        ListPerimeO.DataBodyRange.Rows(ListPerimeO.DataBodyRange.Rows.Count).Offset(0, -3) = Liste.Offset(0, -3)
ListPerimeO.DataBodyRange.Rows(ListPerimeO.DataBodyRange.Rows.Count).Offset(0, -2) = Liste.Offset(0, -2)
        ListPerimeO.DataBodyRange.Rows(ListPerimeO.DataBodyRange.Rows.Count).Offset(0, -1) = Liste.Offset(0, -1)

Je vais avoir au moins dix colonne après et les 4 avant

Le 11/05/2023 à 07:07

Bonjour,

Je ne sais pas a quoi ressemble ton fichier, si tu peux le partager peut-etre qu'on peut trouver une meilleur methode avec une correspondance de nom de colonne.
Si tes tableaux n'ont pas la meme structure le plus simple est de faire des offsets

Ou des boucles suivant ton exemple tu peux faire :

For Col = -4 to 10
ListPerimeO.DataBodyRange.Rows(ListPerimeO.DataBodyRange.Rows.Count).Offset(0, Col) = Liste.Offset(0, Col)
next col

Test un truc comme ça ? (j'ai jamais testé les negatifs dans une boucle sinon divise en 2 boucles ou fait une soustraction "col-4")

A+

Le 11/05/2023 à 08:12

Cétait l'occasion de tester

9changement-couleur-suivant-date-geof4.xlsm (28.59 Ko)
        For col = -2 To 3
            ListPerimeO.DataBodyRange.Rows(ListPerimeO.DataBodyRange.Rows.Count).Offset(0, col) = Liste.Offset(0, col)
        Next col

J'ai juste modifié le remplissage du tableau orange avec une boucle.

Le 11/05/2023 à 13:51

Parfait ! ça fonctionne a merveille un grand merci

Rechercher des sujets similaires à "code vba couleur date echeance"