Sub Archiver()
Dim lig As Long, c As Range, col As Integer
With Feuil2
lig = .[B65536].End(xlUp).Row
For Each c In Feuil1.[B5:B65536,E5:E65536].SpecialCells(xlCellTypeConstants)
If c.Font.ColorIndex = 5 Then 'police bleue
lig = lig + 1
.Cells(lig, "B") = Feuil1.[B1]
Intersect(.Rows(lig), .[C:D,F:F]) = Feuil1.[B2]
.Cells(lig, "E") = DatePart("ww", Feuil1.[B2], 2, 1) 'N° de semaine
.Cells(lig, "G") = Feuil1.Cells(4, c.Column)
.Cells(lig, "H") = c
col = 9
Else
.Cells(lig, col) = c
.Cells(lig, col + 1) = c(1, 2)
col = col + 2
End If
Next
.Activate 'facultatif
End With
End Sub
Sub Test()
'Voir l'Aide VBA pour comprendre DatePart
MsgBox "N° de semaine du 1er type => " & DatePart("ww", "1/1/2012", 2, 1)
MsgBox "N° de semaine du 2ème type => " & DatePart("ww", "1/1/2012", 2, 2)
End Sub