Sub Traitement()
Dim a As Range, i&, j As Byte, t
Application.ScreenUpdating = False
On Error Resume Next 's'il n'y a pas de SpecialCells
With Sheets("Résultat")
Sheets(1).Cells.Copy .Cells
.[J:J].Borders.LineStyle = xlNone 'facultatif
.[J:J].Interior.ColorIndex = xlNone 'facultatif
.[K2:O2] = Array("50 à 59%", "60 à 69%", "70 à 79%", "80 à 89%", "90 à 100%")
For Each a In .Range("J3:J" & Rows.Count).SpecialCells(xlCellTypeConstants).Areas
For i = 1 To a.Count Step 5
For j = 0 To 4
a(i + j).Cut a(i, 6 - j)
Next
Next
Next
.[1:1].Delete
.[J:J].Delete
.[A1:B1] = Array("Date", "N° semaine")
With .Range("A2:A" & Rows.Count)
.UnMerge
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
With .SpecialCells(xlCellTypeConstants).Resize(, 2)
t = .Value 'matrice, plus rapide
For i = 1 To UBound(t)
t(i, 1) = CDate(Replace(t(i, 1), ".", "/"))
t(i, 2) = NoSemISO(t(i, 1))
Next
.Value = t
End With
End With
With .UsedRange: End With 'repositionne la barre de défilement verticale
.Activate
End With
End Sub
Function NoSemISO(d) 'norme ISO(Sem 4 Jrs mini)(de Renauder XLD)
Dim t&
t = DateSerial(Year(d + (8 - Weekday(d)) Mod 7 - 3), 1, 1)
NoSemISO = ((d - t - 3 + (Weekday(t) + 1) Mod 7)) \ 7 + 1
End Function