XL 2013 Colorer les jours dans un planning de présence (Résolu par JOB75)

susaita · 28 Août 2016

Bonjour a tous,
dans le fichier ci-joint j'ai un planning de présence et ce que je souhaite avoir c'est un code vba pour colorer chaque cellule par les couleurs qui se trouvent sur l'onglet DATA, cad quand je choisi un motif d'absence dans la liste que j'ai sur l'onglet septembre-2016 il me donne la couleur qui lui correspond toute en sachant que le code sera valable pour les mois qui vont s'ajouter par la suite.

puis je veux interdire la visualisation de la liste déroulante dans les dimanches

Merci d'avance

susaita · 29 Août 2016

Bonjour Job,
bonjour le forum
merci beaucoup pour le code c'est exactement ce que je voulais..mais j'ai deux petites remarques que je voudrais citer :

***la liste déroulante je voulais l'interdire juste pour le dimanche donc j'ai changé ces deux lignes pour que la liste apparaît sur les samedi :

VB:

If Weekday(ActiveCell(9 - ActiveCell.Row), 2) > 6 Then Else _
  If c Is Nothing Or Weekday(Target(9 - Target.Row), 2) > 6 Then

mais le problème c'est que les samedis restent avec la même couleur orange ils prennent pas la couleur du code

*****en choisissant un code de la liste déroulante il prend du temps en montrant le nom du code avant qu'il se transforme en couleur : j'aimerais éviter ce petit beug comme ça une fois je clique sur un code dans la liste déroulante j'ai directement la couleur

Merci

job75 · 29 Août 2016

Re,

J'ai mis une police blanche sur la plage B10:AF1048576.

Et modifié la MFC des week-ends.

Fichier (3).

A+

susaita · 29 Août 2016

Merci beaucoup Job c'est exactement ce que je voulais

Cordialement
Susaita

job75 · 29 Août 2016

Re,

Dans ce fichier (4), sur les colonnes AH:AT :

- formules plus simples en AH10 et suivantes

- format personnalisé 0;; pour masquer les valeurs zéro

- MFC séparée pour les bordures.

A+

job75 · 29 Août 2016

Re,

Allez un petit complément pour la colonne A :

Code:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim r As Range
If Not IsDate("1-" & Sh.Name) Then Exit Sub
'---colonne A---
Set r = Intersect(Target, Sh.Range("A10:A" & Sh.Rows.Count), Sh.UsedRange)
If Not r Is Nothing Then
  Application.ScreenUpdating = False
  For Each r In r 'si entrées/effacements multiples
    r(1, 34).Resize(, [Codes].Count) = IIf(IsEmpty(r), "", "=COUNTIF(RC2:RC32,R9C)")
    If IsEmpty(r) Then r(1, 2).Resize(, 31) = ""
  Next
End If
'---colonnes B:AF---
Set Target = Intersect(Target, Sh.Range("B10:AF" & Sh.Rows.Count), Sh.UsedRange)
If Target Is Nothing Then Exit Sub
Application.ScreenUpdating = False
On Error Resume Next
For Each Target In Target 'si entrées/effacements multiples
  Set r = [Codes].Find(Target, , xlValues, xlWhole)
  If r Is Nothing Or Weekday(Target(9 - Target.Row)) = 1 Then
    If Target <> "" Then Target = ""
    Target.Interior.ColorIndex = xlNone 'RAZ
    Target.Font.ColorIndex = 2 'RAZ (police blanche sur B10:AF1048576)
  Else
    Target.Interior.Color = r.Interior.Color
    Target.Font.Color = r.Font.Color
  End If
Next
End Sub

Quand on ajoute/efface une formule en colonne A les formules en AH:AT s'ajoutent/s'effacent.

Et quand on l'efface son planning à droite s'efface aussi.

Edit : j'ai modifié les formules des MFC.

Fichier (5).

A+

susaita · 30 Août 2016

Bonsoir Job,
le dernier complément concernant la colonne A ca marche pas chez moi

job75 · 30 Août 2016

Bonjour susaita,

Ah oui je n'avais pas vu que les noms en colonne A sont entrés par formule.

Je viens de modifier le post #20 et le fichier (5), maintenant tirez les formules vers le bas.

Edit : mais vos formules en colonna A ont un grave inconvénient.

Si l'on ajoute des noms dans la feuille "DATA" les noms en colonne A peuvent changer de ligne puisque vos formules les trient.

Alors les plannings ne correspondent plus !!!

Il faudrait dans ce cas revoir votre projet, mais là c'est une tout autre histoire...

A+

susaita · 30 Août 2016

Bonjour Job,
il n y'a pas de solution pour ce problème de colonne A ou je me contente sur la version 4 ???

job75 · 30 Août 2016

Re,

Toutes les versions que j'ai données auront le même problème si l'on ajoute des noms en feuille "DATA".

Le remède : ne pas mettre de formules en colonne A des feuilles de mois.

A+

susaita · 31 Août 2016

Bonsoir job
Et comment je peux avoir les noms de data dans la colonne et sans formule pour que votre code marche??

job75 · 31 Août 2016

Bonjour susaita, le forum,

Voyez ce fichier (6), il n'y a plus de formules pour les noms en colonne A.

J'ai supprimé leur liste en feuille "DATA", elle ne servait plus à rien.

Ajoutez ou effacez les noms que vous voulez dans la feuille concernée (normalement la dernière).

J'ai ajouté un tri sur les noms dans la macro :

Code:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim r As Range
If Not IsDate(Sh.Name) Then Exit Sub
'---colonne A---
Set r = Intersect(Target, Sh.Range("A10:A" & Sh.Rows.Count), Sh.UsedRange)
If Not r Is Nothing Then
  Application.ScreenUpdating = False
  For Each r In r 'si entrées/effacements multiples
    r(1, 34).Resize(, [Codes].Count) = IIf(IsEmpty(r), "", "=COUNTIF(RC2:RC32,R9C)")
    If IsEmpty(r) Then r(1, 2).Resize(, 31) = ""
  Next
  Sh.Range("A10:AT" & Sh.Rows.Count).Sort Sh.[A10], Header:=xlNo 'tri sur les noms
End If
'---colonnes B:AF---
Set Target = Intersect(Target, Sh.Range("B10:AF" & Sh.Rows.Count), Sh.UsedRange)
If Not Target Is Nothing Then
  Application.ScreenUpdating = False
  On Error Resume Next
  For Each Target In Target 'si entrées/effacements multiples
    Set r = [Codes].Find(Target, , xlValues, xlWhole)
    If r Is Nothing Or Weekday(Target(9 - Target.Row)) = 1 Then
      If Target <> "" Then Target = ""
      Target.Interior.ColorIndex = xlNone 'RAZ
      Target.Font.ColorIndex = 2 'RAZ (police blanche sur B10:AF1048576)
    Else
      Target.Interior.Color = r.Interior.Color
      Target.Font.Color = r.Font.Color
    End If
  Next
End If
End Sub

Bonne journée.

susaita · 31 Août 2016

Bonjour Job,
Merci beaucoup ton code est parfait

Cordialement
Susaita

susaita · 31 Août 2016

re Job,
ya t'il possibilté d'accélerer la macro pour que l'affichage des couleurs ne prend pas quelque seconde ??

job75 · 31 Août 2016

Re,

Le délai d'affichage de la couleur ne vient pas de la macro, il suffit d'ajouter un Timer pour s'en rendre compte :

Code:

If Not Target Is Nothing Then
  Dim t
  t = Timer
  Application.ScreenUpdating = False
  On Error Resume Next
  For Each Target In Target 'si entrées/effacements multiples
    Set r = [Codes].Find(Target, , xlValues, xlWhole)
    If r Is Nothing Or Weekday(Target(9 - Target.Row)) = 1 Then
      If Target <> "" Then Target = ""
      Target.Interior.ColorIndex = xlNone 'RAZ
      Target.Font.ColorIndex = 2 'RAZ (police blanche sur B10:AF1048576)
    Else
      Target.Interior.Color = r.Interior.Color
      Target.Font.Color = r.Font.Color
    End If
  Next
  MsgBox Timer - t
End If

Cela ne vient pas non plus des MFC, il suffit de les supprimer, l'affichage reste lent.

Je ne sait pas d'où ça vient, il est possible que votre fichier soit vérolé.

A+

job75 · 31 Août 2016

Re,

Bon rassurez-vous, votre fichier n'est pas vérolé.

J'ai testé sur un nouveau document vierge, sans aucun format, avec juste une feuille contenant la plage "Codes" et une feuille "Septembre-2016" avec les dates en ligne 8.

Il y a là encore un délai pour l'affichage de la couleur, c'est donc le fonctionnement normal sur Excel 2013.

Par curiosité j'ai neutralisé la ligne :

Code:

  'ActiveCell.Validation.Add xlValidateList, Formula1:="=Codes" 'liste de validation

Sans la liste de validation l'affichage est nettement plus rapide.

A+

XL 2013 Colorer les jours dans un planning de présence (Résolu par JOB75)

susaita

XLDnaute Occasionnel

Pièces jointes

susaita

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

Pièces jointes

susaita

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

susaita

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

susaita

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

susaita

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

Pièces jointes

susaita

XLDnaute Occasionnel

susaita

XLDnaute Occasionnel

Pièces jointes

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Discussions similaires