Sub FeuillesSemaines1()
Dim Deb As Long, Fin As Long, i As Long, n As Byte, Tablo(1 To 53, 1 To 2), Sem As Byte, Nom As String, Nom1 As String
Dim tablo1(1 To 53, 1 To 7), x As Integer, y As Byte, k As Byte, j As Byte, Lig As Byte
Deb = DateSerial(2010, 12, 27) 'du Lundi 27 décembre 2010
Fin = DateSerial(2012, 1, 1) 'au Dimanche 01 janvier 2012 soit 53 semaines
For y = 1 To 53
For k = 1 To 7
tablo1(y, k) = Format(Deb + x, "ddd dd mmm yy")
x = x + 1
Next k
Next y
For i = Deb To Fin
If i = Deb Or Weekday(i) = 2 Then n = n + 1: Tablo(n, 1) = Format(i, "dd mmm yy")
If i = Date Then Sem = n
If i = Fin Or Weekday(i) = 1 Then Tablo(n, 2) = Format(i, "dd mmm yy")
Next
Application.ScreenUpdating = False
On Error Resume Next
For i = 1 To n
Nom = "Semaine " & Tablo(i, 1) & " - " & Tablo(i, 2)
Nom1 = "Semaine du " & Format(Tablo(i, 1), "dddd dd mmmm yyyy") & " au " & Format(Tablo(i, 2), "dddd dd mmmm yyyy")
Nom = Sheets(Nom).Name
If Err Then
Err = 0
Sheets("Modele").Copy after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = Nom
Sheets(Sheets.Count).[B1] = Nom1
j = 1
For Lig = 4 To 10
Sheets(Sheets.Count).Range("A" & Lig) = tablo1(i, j)
j = j + 1
Next Lig
End If
Next
Sheets("Semaine " & Tablo(Sem, 1) & " - " & Tablo(Sem, 2)).Select 'semaine en cours
End Sub