Code VBA Calendrier...

[Christian]

Bonjour à tout le forum,

J'ai trouvé sur un site ce code qui permet de générer un calendrier de date à date. J'ai coché l'option (1904) afin de calculer plus facilement des hrs négat sur un plannning. Quelle commande faut-il rajouter à ce code pour que le calendrier ainsi générer (exlp 2004) n'affiche pas 2008...
(code ci-dessous)

Par avance merci
Bien Amicalement
Christian


Sub ConstruireUnCalendrier()
' construit un calendrier dans une colonne
' choix de la cellule de départ par l'utilisateur
' choix des dates de début et fin de calendrier
Dim deb#, fin#, NbJours&, i As Date
Dim Cell As Range, Li&, Col%

On Error Resume Next
deb = CDate(InputBox("Date début de période :"))
fin = CDate(InputBox("Date fin de période :"))

If Err <> 0 Then Exit Sub

Set Cell = Application.InputBox _
("Sélectionnez la cellule $B$4 en haut à gauche (sous la flèche) pour commencer le calendrier", Type:=8)

If Err <> 0 Then Exit Sub

Li = Cell.Row: Col = Cell.Column

For i = deb To fin
Cells(Li, Col).Value2 = i
' If Weekday(i, vbMonday) > 5 Then _
Cells(Li, Col).Interior.ColorIndex = 6
' pour surligner les samedis, dimanches et fériés
If TYPEJOUR(i) = 1 Or TYPEJOUR(i) = 2 Then _
Cells(Li, Col).Interior.ColorIndex = 4
Cells(Li, Col).NumberFormatLocal = "jj jjj aa"
Li = Li + 1
Next i
End Sub

 

[michel]

Bonjour Christian

le plus Long aura été de retrouver la fonction manquante ...
J'ai modifié la procedure , mais je suis vraiment pas sur de mon coup ( nottament pour la gestion des jours fériés ) . il faudra que tu testes les différents cas de figures pour verifier si la modification est bien adaptée

ps
par avance , toutes mes excuses à Laurent Longre si j'ai maltraité sa Démo



Sub ConstruireUnCalendrier()
Dim deb#, fin#, NbJours&, i As Date
Dim Cell As Range, Li&, Col%

On Error Resume Next
deb = CDate(InputBox("Date début de période :", , "format :jj/mm/aa")) - 1462
fin = CDate(InputBox("Date fin de période :", , "format :jj/mm/aa")) - 1462

If Err <> 0 Then Exit Sub

Set Cell = Application.InputBox _
("Sélectionnez la cellule $B$4 en haut à gauche (sous la flèche) pour commencer le calendrier", Type:=8)

If Err <> 0 Then Exit Sub

Li = Cell.Row: Col = Cell.Column

For i = deb To fin
Cells(Li, Col).Value2 = i
If TYPEJOUR(i) = 1 Or TYPEJOUR(i) = 2 Then _
Cells(Li, Col).Interior.ColorIndex = 4
Cells(Li, Col).NumberFormatLocal = "jj jjj aa"
Li = Li + 1
Next i
End Sub

Function TYPEJOUR(D As Date)
'L. Longre
Dim A As Integer, T As Integer
Dim LP As Date, LD As Long

A = Year(D + 1462)
If A > 2099 Then
TYPEJOUR = CVErr(xlErrValue)
Exit Function
End If

LD = Int(D + 1462) + 1
If LD <= 2 Then
If LD = 1 Then TYPEJOUR = 2
Exit Function
End If

T = (((255 - 11 * (A Mod 19)) - 21) Mod 30) + 21
LP = DateSerial(A, 3, 2) + T + (T > 48) _
+ 6 - ((A + A \ 4 + T + (T > 48) + 1) Mod 7)
Select Case D + 1462
' Jours fériés mobiles
Case Is = LP, Is = LP + 38, Is = LP + 49
TYPEJOUR = 2
' Jours fériés fixes
Case Is = DateSerial(A, 1, 1), Is = DateSerial(A, 5, 1), _
Is = DateSerial(A, 5, 8), Is = DateSerial(A, 7, 14), _
Is = DateSerial(A, 8, 15), Is = DateSerial(A, 11, 1), _
Is = DateSerial(A, 11, 11), Is = DateSerial(A, 12, 25)
TYPEJOUR = 2
Case Else
' Samedi ou dimanche
If WeekDay(D + 1462, vbMonday) >= 6 Then TYPEJOUR = 1
End Select

End Function

bonne journée
michel