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

[susaita]

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

 

[JHA]

Bonjour à tous,

Voir fichier ci joint

JHA

 

[susaita]

Bonjour JHA,
Merci pour ta réponse mais j'aimerais bien que le code soit en thisworkbook parce que il sera applicable sur tout les mois qui vont s'ajouter
2ème remarque en sélectionnat le motif d'abasence souhaité, dans le résultat je veux cacher les abréviations garder juste la couleur

 

[JHA]

Bonjour à tous,

Je ne suis pas très bon en code VBA, ci joint une modif, le code est à répéter dans dans la feuille.

Ce n'est pas très compliqué de copier le code dans un nouvel onglet.


JHA

 

[susaita]

Re-Bonjour
Je préfère éviter de repeter le code dans les feuilles qui se rajouteront

 

[JHA]

Re,

Il te faudra attendre d'autres personnes intéressées à résoudre ton soucis.

JHA

 

[susaita]

d'accord JHA
merci beaucoup déjà pour ta proposition

Cordialement
susaita

 

[susaita]

Bonsoir
Ya t'il une autre proposition à ma demande???

Merci

 

[job75]

Bonsoir susaita, JHA,

Fichier joint avec dans ThisWorkbook :

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If IsDate("1-" & Sh.Name) Then
  On Error Resume Next
  For Each Target In Intersect(Target, Sh.Range("B10:AF" & Sh.Rows.Count), Sh.UsedRange) 'si entrées/effacements multiples
    Target.Interior.ColorIndex = xlNone 'RAZ
    Target.Interior.Color = [Codes].Find(Target, , xlValues, xlWhole).Interior.Color
  Next
End If
End Sub

Bonne nuit.

 

[susaita]

Bonsoir Job,
Merci pour votre code mais dans l'onglet septembre-2016 je veux juste voir les couleurs sans les abréviations
c'est à dire au lieu de voir AA ou AB avec la couleur je veux juste voir la couleur et cacher l'écriture

 

[job75]

Re,

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If IsDate("1-" & Sh.Name) Then
  On Error Resume Next
  For Each Target In Intersect(Target, Sh.Range("B10:AF" & Sh.Rows.Count), Sh.UsedRange) 'si entrées/effacements multiples
    Target.Interior.ColorIndex = xlNone 'RAZ
    With [Codes].Find(Target, , xlValues, xlWhole)
      Target.Interior.Color = .Interior.Color
      Target.Font.Color = .Font.Color
    End With
  Next
End If
End Sub

Re-bonne nuit.

 

[susaita]

re,
merci beaucoup pour le code
il reste un dernier point c'est le dimanche je veux que la liste déroulante ne soit pas visible pour ce jour

Bonne nuit

 

[JHA]

Bonjour à tous,
Bonjour Job75

Tu peux modifier la liste de validation.
Onglet Données/Validation des données/liste:
=SI(JOURSEM(B$9;2)=7;"";Codes)

Dans l'exemple, cela est fait pour l'onglet "Septembre-2016", à toi de l'appliquer sur "Octobre-2016"

JHA

 

[susaita]

bonjour JHA,
Bonjour JOB75

c'est ce que je veux sauf que j'aimerais que ce soit automatique pour ne pas le faire après chaque ajout d'un mois

Cordialement
Susaita

 

[job75]

Bonjour susaita, JHA, le forum,

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If Not IsDate("1-" & Sh.Name) Then Exit Sub
With Sh.Range("B10:AF" & Sh.Rows.Count)
  .Validation.Delete 'RAZ
  If Intersect(ActiveCell, .Cells) Is Nothing Then Exit Sub
End With
On Error Resume Next
If Weekday(ActiveCell(9 - ActiveCell.Row), 2) > 5 Then Else _
  ActiveCell.Validation.Add xlValidateList, Formula1:="=Codes" 'liste de validation
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim c As Range
If Not IsDate("1-" & Sh.Name) Then Exit Sub
Set Target = Intersect(Target, Sh.Range("B10:AF" & Sh.Rows.Count), Sh.UsedRange)
If Target Is Nothing Then Exit Sub
On Error Resume Next
For Each Target In Target 'si entrées/effacements multiples
  Target.Interior.ColorIndex = xlNone 'RAZ
  Target.Font.ColorIndex = xlAutomatic 'RAZ
  Set c = [Codes].Find(Target, , xlValues, xlWhole)
  If c Is Nothing Or Weekday(Target(9 - Target.Row), 2) > 5 Then
    If Target <> "" Then Target = ""
  Else
    Target.Interior.Color = c.Interior.Color
    Target.Font.Color = c.Font.Color
  End If
Next
End Sub

Edit : j'ai revu la macro Workbook_SheetChange.

J'ai aussi revu les MFC, pour les bordures et les week-ends.

Fichier (2).

A+