Bonsoir/bonjour à tous ! Comment faire pour que cet "agenda" colore la plage en cours je m'explique?

anthoYS

XLDnaute Barbatruc
Voilà, dans mon fichier joint, un planning que j'ai élaborer, en fait ça marche par quart d'heure les cellules, mais sur la gauche, on a toutes les demi-heures.
On va donc se référer à la demi-heure, je souhaite colorer en jaune la tranche horaire en cours, s'il est 7h27 par exemple, colorer de jaune A2:A3 ainsi que E2:E3 (si c'est jeudi).

Si c'est une plage qui est concernée, colorer toute la plage concernée, mais en A, seulement colorer la plage horaire.

---

Aussi, je voudrais même si en cherchant je peux trouver ça, c'est donc optionnel, pouvoir changer automatiquement les dates de semaines de B1:H1. A savoir, si nous sommes lundi 26/06/2017, bah automatiser la plage entière avec les nouvelles dates de la semaines en cours...

J'insiste ça reste optionnel, je dois pouvoir trouver pour ça dans mes archives... je le met au cas où pour que vous ayez une idée de mon projet/souhait. Je posterais le fichier final si j'y pense, ça peut toujours profiter à d'autres mes idées...


Merci
Bonne nuit où journée !
à bientôt !
 

Fichiers joints

Lolote83

XLDnaute Accro
Salut AnthoYS,
Un début de piste ici
Une colonne B (masquée) reprend les valeurs horaires au format horaire pour MFC
En C2, inscrire la date de début pour que la semaine puisse être mise à jour
En A2, l'heure actuelle (F9 pour actualisation)

Par contre, je n'ai pas compris ta demande
Si c'est une plage qui est concernée, colorer toute la plage concernée, mais en A, seulement colorer la plage horaire.
@+ Lolote83
 

Fichiers joints

Lolote83

XLDnaute Accro
Salut BEBERE, ANTHOYS,
Quand je lance ton code, c'est toute la colonne F (donc du jour qui se colore). Est-ce normal ?
Sinon, je n'ai vraiment pas compris la consigne.
@+ Lolote83
 

phlaurent55

XLDnaute Barbatruc
Bonjour à tous,

sur base du fichier de Lolotte, pour colorier la cellule correspondant à l'heure et au jour actuels
Mais il ne faut pas perdre de vue que les cellules fusionnées ( ou non fusionnées dans le cas présent) sont de nature à amener des complications

à+
Philippe
 

Fichiers joints

anthoYS

XLDnaute Barbatruc
Merci à vous 3 !


Je prends connaissance à l'instant de votre labeur...
@Lolote83 : tu dis ne pas comprendre ma demande pourtant tu y répond à peu près correctement... je ne vois pas où j'ai manqué de précisions... en général je suis précis... Soit. Je reformule, après relecture, ça pouvait effectivement prêter à confusion : En fait, si une plage de données est concernée par l'heure actuelle, quand je dis plage il s'agit d'une plage concaténée de C4:I84. Sur un jour donnée, tout dépend le jour en cours...
Par exemple pour être concret, nous sommes un mercredi 9 h, bah colorer de jaune la plage D6:D13 entièrement.

@phlaurent55 : merci beaucoup c'est encore mieux que je le souhaitais, les quart d'heures sont en fond jaune, excellent.

Ok @Bebere ;)


Bonne fin de journée !
 
Dernière édition:

Bebere

XLDnaute Barbatruc
bonjour Phlaurent
je te rejoins pour les cellules fusionnées
un autre code à tester
Code:
Public Sub Colore()
    Dim h As Date, d As Date, f As Date, hi As Date, m As Date, l As Long, li As Long, c As Byte, x As String
    Dim pos As Byte, posh As Byte
    Range("A2:A82").Interior.ColorIndex = 1: Range("A2:A82").Font.ColorIndex = 2
    h = Hour(Time) / 24: m = Time - Hour(Time) / 24
    For l = 2 To 82 Step 2
        pos = InStr(Cells(l, 1).Value, "-")
        posh = InStr(Cells(l, 1).Value, "h")
        x = Mid(Cells(l, 1), 1, posh - 1)
        If x / 24 = h Then
            If Val(Right(Cells(l, 1).Value, 2)) = "30" Then
                If m <= "00:30" Then
                    li = l
                    Exit For
                Else
                    If m > "00:30" Then
                        li = l + 2
                        Exit For
                    End If
                End If
            End If
        End If
    Next l
    Cells(li, 1).Interior.ColorIndex = 6: Cells(li, 1).Font.ColorIndex = xlAutomatic

    For c = 2 To 8
        If Cells(1, c) = Date Then Exit For
    Next c
    Range(Cells(2, c), Cells(82, c)).Interior.ColorIndex = xlNone
    Range(Cells(2, c), Cells(li + 1, c)).Interior.ColorIndex = 6

End Sub
 

job75

XLDnaute Barbatruc
Bonjour à tous,

@ phlaurent55 et Bebere

Alors vous aussi vous faites partie des gens atteints de la phobie des cellules fusionnées.

Pendant mes 9 ans sur XLD elles ne m'ont causé aucun problème * et j'en ai vues des tonnes.

* Bien sûr elles n'acceptent pas de formules matricielles et c'est normal.

A+
 

job75

XLDnaute Barbatruc
Re,

Voyez le fichier joint et cette macro dans ThisWorkbook :
Code:
Private Sub Workbook_Open()
Dim h#, lig&, col%
Feuil1.Activate 'CodeName de la feuille "edp"
[A1:H1].Select
With ActiveWindow: .Zoom = True: .ScrollRow = 1: .ScrollColumn = 1: End With 'cadrage
[A1].Select
[B1] = Date - Weekday(Date, 2) + 1 'MAJ du lundi en B1
[A2:H83].FormatConditions.Delete 'RAZ de la MFC
h = Hour(Now) + Minute(Now) / 60
If h < 3.5 Or h >= 7 Then
  If h < 3.5 Then h = h + 24
  lig = 4 * Application.Floor(h - 7, 1 / 4) + 2
  col = Application.Match(CDbl(Date), [1:1], 0)
  With Union(Cells(lig, 1).MergeArea, Cells(lig, col).MergeArea)
    .FormatConditions.Add xlExpression, Formula1:="=1" 'création de la MFC
    .FormatConditions(1).Interior.ColorIndex = 6 'jaune
    .FormatConditions(1).Font.ColorIndex = xlAutomatic
    .FormatConditions(1).Font.Bold = True 'gras
  End With
End If
Me.Saved = True 'évite l'invite à la fermeture si aucune modification
End Sub
Nota : les cellules fusionnées sont colorées entièrement par la MFC.

A+
 

Fichiers joints

Dernière édition:

job75

XLDnaute Barbatruc
Re,

Une solution plus élaborée dans ce fichier (2).

Elle consiste à mettre à jour la feuille toutes les minutes.

Dans ThisWorkbook :
Code:
Private Sub Workbook_Open()
Feuil1.Activate 'CodeName de la feuille "edp"
[A1:H1].Select
With ActiveWindow: .Zoom = True: .ScrollRow = 1: .ScrollColumn = 1: End With 'cadrage
[A1].Select
MAJ 'lance le processus de calcul
Me.Saved = True
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
If Not Me.Saved Then Me.Save 'enregistrement automatique
On Error Resume Next
Application.OnTime t, "MAJ", , False 'arrête le processus de calcul
End Sub
Dans Module1 :
Code:
Public t# 'mémorise la variable

Sub MAJ()
Dim s, h#, lig&, col%
s = ThisWorkbook.Saved 'mémorise l'état
Application.ScreenUpdating = False
With Feuil1 'CodeName
  .[B1] = Date - Weekday(Date, 2) + 1 'MAJ du lundi en B1
  .[A2:H83].FormatConditions.Delete 'RAZ de la MFC
  h = Hour(Now) + Minute(Now) / 60
  If h < 3.5 Or h >= 7 Then
    If h < 3.5 Then h = h + 24
    lig = 4 * Application.Floor(h - 7, 1 / 4) + 2
    col = Application.Match(CDbl(Date), .[1:1], 0)
    With Union(.Cells(lig, 1).MergeArea, .Cells(lig, col).MergeArea)
      .FormatConditions.Add xlExpression, Formula1:="=1" 'création de la MFC
      .FormatConditions(1).Interior.ColorIndex = 6 'jaune
      .FormatConditions(1).Font.ColorIndex = xlAutomatic
      .FormatConditions(1).Font.Bold = True 'gras
    End With
  End If
End With
If s Then ThisWorkbook.Saved = True
On Error Resume Next
Application.OnTime t, "MAJ", , False 'RAZ du processus de calcul
t = Application.Floor(Now, 1 / 1440) + 1 / 1440 'recalcul chaque minute/système
Application.OnTime t, "MAJ"
End Sub
Edit : j'ai mis le recalcul à chaque changement de minute/système, c'est plus clair.

A+
 

Fichiers joints

Dernière édition:

job75

XLDnaute Barbatruc
Re,

J'avais écrit h <= 3.5 il faut h < 3.5 j'ai corrigé les 2 fichiers.

Bonne nuit.
 

anthoYS

XLDnaute Barbatruc
Merci beaucoup @job75 pour ton dévouement et ton sérieux ainsi que ta capacité à assimiler les diverses fonctions d'Excel. Tu dois bosser souvent dessus !

:)
 

anthoYS

XLDnaute Barbatruc
Bien, je reviens j'ai un léger soucis :)
en effet ça me colore la tranche 10h45-11h du lundi en plus de la bonne tranche en cours...

étrange...
 

Fichiers joints

anthoYS

XLDnaute Barbatruc
maintenant c'est le foutoir complet, j'ai rajouter des activités ça les colore, je laisse tomber pour aujourd'hui...
 

Fichiers joints

Discussions similaires


Haut Bas