Discussion :

[Un Internaute]

Bonjour le forum
Comme vous pourez le constater la ligne du jour (couleur 17) est au dessous de la ligne d'aujourdh'ui
Comment obtenir avec la macro qui est dans ThisWorkbook et Colorise la ligne du jour (interiorcolor 17 ) aujourdh'ui sans MFC?
Cordialement


PS: Pour être correct j'ai posté sur 2 forums avec une seule réponse. j'ai cru que c'était bon mais fause alerte le matin à l'ouverture du fichier

[Invité]

Bonjour,

Dans ton module "COLORISE", ta boucle et la colorisation se fait sur la première cellule vide trouvée
si tu lui retranche une ligne, tu auras la couleur sur la ligne du jour
sans oublier de supprimer la MFC

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
Sub Colorise_Jour()
Dim J As Long
 
  For J = 6 To 36
    If Range("B" & J) = "" And Range("C" & J) = "" Then
      If J > 6 Then
        Range("A" & J - 1 & ":G" & J - 1).Interior.ColorIndex = 17
      End If
      Exit For
    End If
  Next J
End Sub

[Theze]

Bonjour,

Pour que ça puisse marcher à l'ouverture du classeur, il faudrait que la date du jour soit déjà entrée donc, soit tu entres toutes les dates du mois et tu auras alors la date du jour surlignée à l'ouverture du classeur soit tu utilises la procédure événementielle "Workbook_SheetChange()" et la coloration se fera à la saisie de la date du jour.
Code à mettre dans la proc "Workbook_SheetChange()" :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
 
Range("A6:G33").Interior.ColorIndex = 8 'supprime pour le jour n'étant plus aujourd'hui
If Target.Value = Date Then Range(Target, Target.Offset(, 6)).Interior.ColorIndex = 17

Pour le cas de l'ouverture du classeur avec toutes les dates du mois en colonne A. Le place ici tout le code car modifié à plusieurs endroits (voir les ***) :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
 
Private Sub Workbook_Open()
 
    Dim wSheet As Worksheet
    Dim Feuille As String, AMasquer As String
    Dim I As Integer
    '******************************************************
    Dim Plage As Range
    Dim Cel As Range
    Dim F As String
    '******************************************************
 
    Application.ScreenUpdating = False
    For Each wSheet In Worksheets: wSheet.Protect UserInterfaceOnly:=True: Next wSheet
 
    Feuille = MonthName(Month(Date)) & " " & Year(Date)
 
    If FeuilleExiste(Feuille) = False Then Exit Sub
 
    '******************************************************
    'défini la plage sur la colonne A à G à partir de A6
    With Worksheets(Feuille): Set Plage = .Range(.Cells(6, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 7): End With
 
    'mémorise le formatage de la colonne A puis passe la colonne A au format "Standard" pour avoir des valeurs de type Long
    F = Plage.Columns(1).NumberFormat
    Plage.Columns(1).NumberFormat = "General"
 
    'effectue la recherche de la date en type Long sur la colonne A
    Set Cel = Plage.Columns(1).Find(CLng(Date), , xlValues, xlWhole)
 
    'puis rétabli le format
    Plage.Columns(1).NumberFormat = F
 
    'si trouvée, mets la plage au fond 8 puis colore la ligne du jour
    If Not Cel Is Nothing Then
 
        With Worksheets(Feuille)
 
            Plage.Interior.ColorIndex = 8
            .Range(.Cells(Cel.Row, 1), .Cells(Cel.Row, Plage.Columns.Count)).Interior.ColorIndex = 17
 
            'colore ensuite les cellules en fonction du jour
            For I = 6 To Cel.Row - 1
                ' Férié ou WE
                If Application.CountIf(Sheets("Menu").Range("JOursFériés"), .Range("A" & I)) > 0 Or Weekday(.Range("A" & I), vbMonday) > 5 Then
 
                    .Range("A" & I & ":G" & I).Interior.ColorIndex = 38
 
                Else
 
                    .Range("A" & I).Interior.ColorIndex = 15
                    .Range("B" & I).Interior.ColorIndex = 6
                    .Range("C" & I).Interior.ColorIndex = 4
                    .Range("D" & I & ":G" & I).Interior.ColorIndex = 43
 
                End If
            Next I
 
        End With
 
 
    End If
    '******************************************************
 
    If UCase(Feuille) <> UCase(ActiveSheet.Name) Then
        ' Teste le nom en majuscule de la feuille du mois en cours avec le nom en majuscule de la feuille affichée
      AMasquer = ActiveSheet.Name
      With Sheets(Feuille)
        .Visible = True
        .Select
      End With
      Sheets(AMasquer).Visible = xlSheetVeryHidden
    End If
 
    For I = 1 To Sheets.Count
      If UCase(Sheets(I).Name) <> UCase(Feuille) Then Sheets(I).Visible = xlSheetVeryHidden
    Next I
 
    '******************************************************
    'suspend les événements afin que la procédure "Workbook_SheetChange()" ne soit pas exécuté (coloration des cellules)
    Application.EnableEvents = False
 
    If Time > TimeSerial(12, 0, 0) Then
      Sheets(Feuille).Range("C" & 5 + Day(Date)) = 3
    Else
      Sheets(Feuille).Range("B" & 5 + Day(Date)) = 3
    End If
 
    Sheets(Feuille).Range("B" & 5 + Day(Date)).Resize(1, 2).HorizontalAlignment = xlCenter
 
    'rétabli
    Application.EnableEvents = True
    '******************************************************
 
End Sub

[unparia]

Bonjour
J'ai personnellement des difficultés à comprendre la nécessité d'une boucle dans le code montré, à savoir :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
Sub Colorise_Jour()
  Dim J As Long
  For J = 6 To 36
    If Range("B" & J) = "" And Range("C" & J) = "" Then
      If J > 6 Then
        Range("A" & J - 1 & ":G" & J - 1).Interior.ColorIndex = 17
      End If
      Exit For
    End If
  Next J
End Sub

qui ne fait rien d'autre que ce que ferait ce code

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Dim ou As Long
  ou = WorksheetFunction.Max(Range("B1").End(xlDown).Row + 1, Range("C1").End(xlDown).Row + 1)
  Range("A" & ou & ":G" & ou).Interior.ColorIndex = 17

EDIT : et si (comme on pourrait le deviner) aucune ligne n'est complètement vide entre deux lignes remplies à partir de la ligne 6 (pour les colonne B et c) -->> c'est encore plus simple ==>>

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Dim ou As Long
  ou = WorksheetFunction.Max(Range("B36").End(xlUp).Row, Range("C36").End(xlUp).Row)
  Range("A" & ou & ":G" & ou).Interior.ColorIndex = 17

[Un Internaute]

Bonjour unparia
Ce code je le met où stpl?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Dim ou As Long
  ou = WorksheetFunction.Max(Range("B36").End(xlUp).Row, Range("C36").End(xlUp).Row)
  Range("A" & ou & ":G" & ou).Interior.ColorIndex = 17

[unparia]

Ce code je le met où stpl?

Je n'en sais rigoureusement rien -->> lis ma signature : je n'ouvre jamais un classeur tiers et n'ai pas ouvert le tien.
Le code que j'ai montré se substitue à celui que tu as montré, dont j'ignore y compris à quoi il correspond sur ton classeur.

[Un Internaute]

Bonjour,

Pour que ça puisse marcher à l'ouverture du classeur, il faudrait que la date du jour soit déjà entrée donc, soit tu entres toutes les dates du mois et tu auras alors la date du jour surlignée à l'ouverture du classeur soit tu utilises la procédure événementielle "Workbook_SheetChange()" et la coloration se fera à la saisie de la date du jour.
Code à mettre dans la proc "Workbook_SheetChange()" :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
 
Range("A6:G33").Interior.ColorIndex = 8 'supprime pour le jour n'étant plus aujourd'hui
If Target.Value = Date Then Range(Target, Target.Offset(, 6)).Interior.ColorIndex = 17

Pour le cas de l'ouverture du classeur avec toutes les dates du mois en colonne A. Le place ici tout le code car modifié à plusieurs endroits (voir les ***) :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
 
Private Sub Workbook_Open()
 
    Dim wSheet As Worksheet
    Dim Feuille As String, AMasquer As String
    Dim I As Integer
    '******************************************************
    Dim Plage As Range
    Dim Cel As Range
    Dim F As String
    '******************************************************
 
    Application.ScreenUpdating = False
    For Each wSheet In Worksheets: wSheet.Protect UserInterfaceOnly:=True: Next wSheet
 
    Feuille = MonthName(Month(Date)) & " " & Year(Date)
 
    If FeuilleExiste(Feuille) = False Then Exit Sub
 
    '******************************************************
    'défini la plage sur la colonne A à G à partir de A6
    With Worksheets(Feuille): Set Plage = .Range(.Cells(6, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 7): End With
 
    'mémorise le formatage de la colonne A puis passe la colonne A au format "Standard" pour avoir des valeurs de type Long
    F = Plage.Columns(1).NumberFormat
    Plage.Columns(1).NumberFormat = "General"
 
    'effectue la recherche de la date en type Long sur la colonne A
    Set Cel = Plage.Columns(1).Find(CLng(Date), , xlValues, xlWhole)
 
    'puis rétabli le format
    Plage.Columns(1).NumberFormat = F
 
    'si trouvée, mets la plage au fond 8 puis colore la ligne du jour
    If Not Cel Is Nothing Then
 
        With Worksheets(Feuille)
 
            Plage.Interior.ColorIndex = 8
            .Range(.Cells(Cel.Row, 1), .Cells(Cel.Row, Plage.Columns.Count)).Interior.ColorIndex = 17
 
            'colore ensuite les cellules en fonction du jour
            For I = 6 To Cel.Row - 1
                ' Férié ou WE
                If Application.CountIf(Sheets("Menu").Range("JOursFériés"), .Range("A" & I)) > 0 Or Weekday(.Range("A" & I), vbMonday) > 5 Then
 
                    .Range("A" & I & ":G" & I).Interior.ColorIndex = 38
 
                Else
 
                    .Range("A" & I).Interior.ColorIndex = 15
                    .Range("B" & I).Interior.ColorIndex = 6
                    .Range("C" & I).Interior.ColorIndex = 4
                    .Range("D" & I & ":G" & I).Interior.ColorIndex = 43
 
                End If
            Next I
 
        End With
 
 
    End If
    '******************************************************
 
    If UCase(Feuille) <> UCase(ActiveSheet.Name) Then
        ' Teste le nom en majuscule de la feuille du mois en cours avec le nom en majuscule de la feuille affichée
      AMasquer = ActiveSheet.Name
      With Sheets(Feuille)
        .Visible = True
        .Select
      End With
      Sheets(AMasquer).Visible = xlSheetVeryHidden
    End If
 
    For I = 1 To Sheets.Count
      If UCase(Sheets(I).Name) <> UCase(Feuille) Then Sheets(I).Visible = xlSheetVeryHidden
    Next I
 
    '******************************************************
    'suspend les événements afin que la procédure "Workbook_SheetChange()" ne soit pas exécuté (coloration des cellules)
    Application.EnableEvents = False
 
    If Time > TimeSerial(12, 0, 0) Then
      Sheets(Feuille).Range("C" & 5 + Day(Date)) = 3
    Else
      Sheets(Feuille).Range("B" & 5 + Day(Date)) = 3
    End If
 
    Sheets(Feuille).Range("B" & 5 + Day(Date)).Resize(1, 2).HorizontalAlignment = xlCenter
 
    'rétabli
    Application.EnableEvents = True
    '******************************************************
 
End Sub

Bonjour Theze
Si tu télécharge mon fichier peux-tu stp le mettre à jour avec cette procédure

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
Range("A6:G33").Interior.ColorIndex = 8 'supprime pour le jour n'étant plus aujourd'hui
If Target.Value = Date Then Range(Target, Target.Offset(, 6)).Interior.ColorIndex = 17

Sinon on stop tout
Merci à toi

[Theze]

Si tu télécharge mon fichier peux-tu stp le mettre à jour avec cette procédure

tu les mets sous ce bloc :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
 
If Target.Row - 5 > Day(Date) Then
    Beep
    MsgBox "PAS LE BON JOUR"
    Target = ""
Else

donc :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
 
If Target.Row - 5 > Day(Date) Then
    Beep
    MsgBox "PAS LE BON JOUR"
    Target = ""
Else
 
    Range("A6:G33").Interior.ColorIndex = 8 'supprime pour le jour n'étant plus aujourd'hui
    If Target.Value = Date Then Range(Target, Target.Offset(, 6)).Interior.ColorIndex = 17

par contre, il te faudrait re colorer les lignes du dessus !

[Un Internaute]

Oui j'ai vu
Et dans Colorise je garde mon code ancien?

[Theze]

Testes le code en lieu et place de l'autre. Ta procédure "Colorise_Jour()" ne servant plus à rien :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
 
    Dim NombreJour As Integer
    Dim Ladate As Date
    Dim MoisSuivant As String
 
    If Target.Count > 1 Then Exit Sub
 
    Application.EnableEvents = False
    ' On recherche si la page est surveillée
    If InStr(1, "JanvierFévrierMarsAvrilMaiJuinJuilletAoûtSeptembreOctobreNovembreDécembre", Split(Sh.Name, " ")(0), vbTextCompare) Then
 
    ' Calcul du nombre de jour dans le mois indiqué par le nom de la feuille
    NombreJour = Day(DateAdd("m", 1, DateValue(Sh.Name)) - 1)
 
    If Target.Row - 5 > Day(Date) Then
 
        Beep
        MsgBox "PAS LE BON JOUR"
        Target = ""
 
    Else
 
        If Range("A" & Target.Row) <> "" Then
 
            Range("A6:G33").Interior.ColorIndex = 8
 
            For I = 6 To Target.Row - 1
            ' Férié ou WE
                If Application.CountIf(Sheets("Menu").Range("JOursFériés"), Range("A" & I)) > 0 Or Weekday(Range("A" & I), vbMonday) > 5 Then
 
                    Range("A" & I & ":G" & I).Interior.ColorIndex = 38
 
                Else
 
                    Range("A" & I).Interior.ColorIndex = 15
                    Range("B" & I).Interior.ColorIndex = 6
                    Range("C" & I).Interior.ColorIndex = 4
                    Range("D" & I & ":G" & I).Interior.ColorIndex = 43
 
                End If
 
            Next I
 
        End If
 
        'Range("A6:G33").Interior.ColorIndex = 8 'supprime pour le jour n'étant plus aujourd'hui
        If Target.Value = Date Then Range(Target, Target.Offset(, 6)).Interior.ColorIndex = 17
 
        ' Surveille la plage du 1er au dernier jours du mois
        If Not Intersect(Range("B6:C" & 5 + NombreJour), Target) Is Nothing Then
        ' Reconstruit la date de fonction du nom de la feuille et du numéro de ligne sélectionnée
            Ladate = DateSerial(Split(Sh.Name, " ")(1), Month(DateValue(Sh.Name)), Target.Row - 5)
            ' Si la colonne B et la colonne C est vide on efface la date
            Range("A" & Target.Row) = IIf(Range("B" & Target.Row) & Range("C" & Target.Row) = "", "", Ladate)
 
            ' si la ligne modifiée est la dernière du mois et que la colonne est la C
            If Target.Row = NombreJour + 5 And Target.Column = 3 Then
                ' On construit le nom de la feuille du mois suivant
                MoisSuivant = MonthName(Month(DateAdd("m", 1, DateValue(Sh.Name)))) & " " & Year(DateAdd("m", 1, DateValue(Sh.Name)))
                ' On va vérifier si la feuille existe
                If FeuilleExiste(MoisSuivant) = False Then Exit Sub
                    ' La feuille existe
                    With Sheets(MoisSuivant)
                        'On la rend visible
                        .Visible = xlSheetVisible
                        ' On masque celle que l'on vient de finir
                        ActiveSheet.Visible = xlSheetHidden
                        ' et on la sélectionne
                        .Select
                    End With
                End If
            End If
        End If
    End If
 
  Application.EnableEvents = True
End Sub