Pourquoi la ligne de hier reste en interior color 17?
Bonjour le forum
La ligne de hier 02/10/2019 reste en interior color 17 alors qu'elle devrait être avec ses couleurs normales suivant les colonnes c'est à dire 15 6 4 43
Si je tape 3 aujourd’hui elle passe bien interior color 17
Je ne suis pas sous MFC volontairement
Merci à vous
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim NombreJour&, Ladate As Date, MoisSuivant$, Plage As Range, cel As Range, F$, i&, J&
If Target.Count > 1 Then Exit Sub
Application.EnableEvents = False
' On recherche si la page est surveillée
If IsDate("1/" & Sh.Name) Then 'plus simple non ???
' 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 = ""
Range(Cells(Target.Row, 1), Cells(Target.Row, 7)).Interior.ColorIndex = 8
Else
' 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) = "", "", Application.Proper(Format(Ladate, "dddd dd mmmm yyyy")))
Range("H" & Target.Row) = IIf(Range("B" & Target.Row) & Range("C" & Target.Row) = "", "", Ladate)
If Range("A" & Target.Row) = "" Then Cells(Target.Row, 1).Resize(, 7).Interior.ColorIndex = 8
' 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
If Range("A" & Target.Row) <> "" Then
Application.ScreenUpdating = False 'NombreJour
Set Plage = Range(Cells(6, 1), Cells(5 + NombreJour, 1)).Resize(, 7) 'Mettre 5 dans ligne macro => Cells(5 + NombreJour, 1)).Resize(, 7) au lieu de 6 pour ne pas afficher ligne 27 les mois de 31 jours
Set cel = Plage.Columns(8).Find(Date, , xlValues, xlWhole) ' Colonne 8 = colonne H (Colonne de la date au format Date)
'puis rétabli le format
' Plage.Columns(1).NumberFormat = F
Plage.Interior.ColorIndex = 8
'si trouvée, mets la plage au fond 8 puis colore la ligne du jour
If Not cel Is Nothing Then
Range(Cells(cel.Row, 1), Cells(cel.Row, Plage.Columns.Count)).Interior.ColorIndex = 17
J = cel.Row - 1
End If
If J = 0 Then J = Plage.Rows.Count + 6
'colore ensuite les cellules en fonction du jour
For i = 6 To J
If Cells(i, 1).Value <> "" Then
If Application.CountIf(Sheets("Menu").Range("JoursFériés"), Range("H" & i)) > 0 Or Weekday(Range("H" & 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
End If
Next i
Application.ScreenUpdating = True
End If
End If
End If
Application.EnableEvents = True
Call DerniereLigne
End SubJ'ai oublié que j'ai cette macro aussi
Sub DerniereLigne()
Dim i&, dat As Date, nb&, fin&, nbj&, col, a&
Application.ScreenUpdating = 0
For i = 1 To Sheets.Count
If Sheets(i).Name <> "MENU" Then
With Sheets(i)
fin = .Range("A" & Rows.Count).End(3).Row
If fin > 4 Then
If Month("1/" & .Name) < 9 Then
dat = .Range("A" & fin)
Else
dat = .Range("H" & fin)
End If
nb = Day(dat)
nbj = Day(DateSerial(Year(dat), Month(dat) + 1, 0))
If dat = Date Then
.Cells(fin, 1).Resize(, 7).Interior.ColorIndex = 17
ElseIf Application.CountIf(Sheets("Menu").Range("JoursFériés"), dat) > 0 Or Weekday(dat, vbMonday) > 5 Then
.Cells(fin, 1).Resize(, 7).Interior.ColorIndex = 38
Else
a = 1
For Each col In Array(15, 6, 4, 43, 43, 43, 43)
.Cells(fin, a).Interior.ColorIndex = col: a = a + 1
Next col
End If
End If
End With
End If
Next i
End SubLa ligne de hier 02/10/2019 reste en interior color 17 alors qu'elle devrait être avec ses couleurs normales suivant les colonnes c'est à dire 15 6 4 43
Si je tape 3 aujourd’hui elle passe bien interior color 17
Je ne suis pas sous MFC volontairement
Merci à vous
Bonjour,
justement, pourquoi "pas de MFC" ?
pour une actualisation automatique, il faudrait aussi une macro workbook_open et une macro worksheet_activate dans ton cas, sinon en effet il ne se passera rien !
Bonjour Steelson
J'en ai 4 qui sont TOUS différents
Je vais essayer de gratter un peu plus et faire des tests pendant quelques et si je ne trouve pas je reviens sur le forum
Donc en attendant je mets Résolu pour éviter de chercher pour rien
Bien cordialement
Bonjour le forum
Comme promis
Il fallait tout simplement ajouter ceci dans la macro
Call DerniereLignePrivate Sub Workbook_Open()
Dim wSheet As Worksheet
Dim Feuille As String, AMasquer As String
Dim i As Integer
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
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 'Pour afficher tous les Mois
If UCase(Sheets(i).Name) <> UCase(Feuille) Then Sheets(i).Visible = xlSheetVeryHidden 'Pour afficher tous les Mois
Next i 'Pour afficher tous les Mois
Call DerniereLigne
End SubBien cordialement
Bonjour Steelson
Oui quand j'ai vu ta réponse ça a fait tilt
Merci à toi
Bonne journée
Cordialement