Option Explicit
Public MoisActuel As String
Public AnnéeActuelle As String
'Public i As Integer
Const sWd As String = "Heure"
Sub FeuilMoisActuel()
MoisActuel = Format(Date, "mmm yyyy")
AnnéeActuelle = Format(Date, "yyyy")
Application.ScreenUpdating = False
If Sheets(1).Name = "Feuil1" Then
' Sheets(1).Name = MoisActuel
Sheets(1).Tab.Color = 39423
Columns("A:A").ColumnWidth = 2
Columns("B:C").ColumnWidth = 4
Columns("D:D").ColumnWidth = 10
Columns("E:F").ColumnWidth = 8
Columns("G:J").ColumnWidth = 6
Columns("K:K").ColumnWidth = 8
Columns("L:L").ColumnWidth = 2
Rows("1:1").RowHeight = 12
Dim CheminLogo As String
CheminLogo = "C:\Logos\" & "TEC.jpg"
ActiveSheet.Shapes.AddPicture CheminLogo, True, True, 15, 1, 383, 57
' Identité.Show
Range("B1:K4,B5:K5").MergeCells = True
Dim Form$, IntV&, arrSTR, i As Byte
arrSTR = Array("Date", "Type", sWd & " Début" & Chr(10) & "de Service", sWd & " Fin" & Chr(10) & "de Service", _
"Nb " & sWd & "s" & Chr(10) & "Travaillées", sWd & "s" & Chr(10) & "de jour", sWd & "s" & Chr(10) & "de nuit", _
sWd & "s" & Chr(10) & "à 150%", sWd & "s" & Chr(10) & "à 200%", sWd & "s" & Chr(10) & "Sam/Dim")
With Range("B1:K4,B5:K5,B6,C6,D6,E6,F6,G6,H6,I6,J6,K6")
.BorderAround 1, 4, -4105: .Interior.Color = 39423
.Font.Size = 9: .Font.Bold = True
.HorizontalAlignment = -4108: .VerticalAlignment = -4108
End With
Range("B5:K5").HorizontalAlignment = 7
Range("B5") = StrConv(Format(Date, "mmmm yyyy"), vbProperCase)
For i = 0 To 9
Cells(6, Chr(66 + i)) = arrSTR(i)
Next i
IntV = CLng(Day(DateSerial(Year(Date), Month(Date) + 1, 0)))
Form = "DATE(YEAR(TODAY()),MONTH(TODAY()),ROW()-6)"
With Range("B7")
.Resize(33, 10).Clear
With .Resize(IntV, 1)
.Font.Size = 9: .Font.Bold = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.FormulaR1C1 = "=TEXT(" & Form & ",""jj"")&MID(""DLMMJVS"",WEEKDAY(" & Form & "),1)"
.Value = .Value
With .Resize(IntV, 10)
.FormatConditions.Add Type:=2, Formula1:="=Droite($B7)=""S"""
.FormatConditions.Add Type:=2, Formula1:="=Droite($B7)=""D"""
.FormatConditions(1).Interior.ThemeColor = 3
.FormatConditions(2).Interior.ThemeColor = 3
.FormatConditions(.FormatConditions.Count).SetFirstPriority
End With
With .Resize(IntV + 1, 10)
.BorderAround 1, 4, -4105
.Borders(11).LineStyle = 1
End With
With Range(Cells(IntV + 7, 2), Cells(IntV + 7, 5))
.MergeCells = True
.Value = "TOTAUX"
End With
With Range(Cells(IntV + 7, 2), Cells(IntV + 7, 11))
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Font.Bold = True
.Interior.Color = 39423
End With
End With
End With
Dim Ddate As Long, Ddebut As Long, Dfin As Long, PAQ As Long
Dim An As Integer, Dstat As String, Dcolor As Long
An = Year(Date)
PAQ = Evaluate("=DATE(" & An & ",3,29.56+0.979*MOD(204-11*MOD(" & An & ",19),30)- WEEKDAY(DATE(" & An & ",3,28.56+0.979*MOD(204-11*MOD(" & An & ",19),30))))")
Ddebut = DateSerial(An, Month(Date), 1)
Dfin = DateSerial(An, Month(Date) + 1, 0)
' Range("B7:C37").ClearContents
i = 1
For Ddate = Ddebut To Dfin
Select Case Ddate
Case DateSerial(An, 1, 1) _
, DateSerial(An, 5, 1) _
, DateSerial(An, 7, 21) _
, DateSerial(An, 8, 15) _
, DateSerial(An, 11, 1) _
, DateSerial(An, 11, 11) _
, DateSerial(An, 12, 25) _
, (PAQ + 1) _
, (PAQ + 39) _
, (PAQ + 50)
With Range("C" & i + 6)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Range("C" & i + 6) = "JF"
Range("B" & i + 6, "K" & i + 6).Interior.Color = vbRed
End Select
i = i + 1
Next Ddate
Else
For i = 1 To Sheets.Count
If Sheets(i).Name = (MoisActuel) Then Exit Sub
Next i
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = MoisActuel
Sheets(MoisActuel).ScrollArea = "A1:Z120"
End If
End Sub
