re rosa14
A tester avec le fichier de ton premier post.
On est d'accord, pas de chevauchement de dates et les données sont triées par ordre chronologique
Option Explicit
Sub test()
Dim a, e, w(), i As Long, ii As Long, n As Long, nbreJ As Long, dico As Object
Set dico = CreateObject("Scripting.Dictionary")
dico.CompareMode = 1
a = Sheets("Absences").Cells(1).CurrentRegion.Value2
For i = 2 To UBound(a, 1)
If Not dico.exists(a(i, 1)) Then
ReDim w(1 To 6, 1 To 1)
For ii = 1 To UBound(a, 2) - 1
w(ii, 1) = a(i, ii)
Next
Else
w = dico(a(i, 1))
If a(i, 2) = w(UBound(w, 1) - 3, UBound(w, 2)) + 1 Then
w(UBound(w, 1) - 3, UBound(w, 2)) = a(i, 3)
Else
ReDim Preserve w(1 To UBound(w, 1), 1 To UBound(w, 2) + 1)
For ii = 1 To UBound(a, 2) - 1
w(ii, UBound(w, 2)) = a(i, ii)
Next
End If
End If
dico(a(i, 1)) = w
Next
For Each e In dico.keys
w = dico.Item(e)
For i = 1 To UBound(w, 2)
nbreJ = w(3, i) - w(2, i) + 1
Select Case nbreJ
Case Is > 30: w(6, i) = nbreJ
Case Is > 3: w(5, i) = nbreJ
Case Else: w(4, i) = nbreJ
End Select
Next
dico.Item(e) = w
Next
Application.ScreenUpdating = False
With Sheets.Add
.Cells(1).Resize(, 6).Value = _
Array("N° Employé", "Date de début Paye", "Date de fin Paye", _
"jours " & ChrW(8804) & " 3", "3 < jours " & ChrW(8804) & " 30", "jours > 30")
n = 2
For Each e In dico.keys
With .Cells(n, 1).Resize(UBound(dico.Item(e), 2), UBound(dico.Item(e), 1))
.Value = Application.Transpose(dico.Item(e))
.BorderAround Weight:=xlThin
End With
n = n + UBound(dico.Item(e), 2)
Next
With .Cells(1).CurrentRegion
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
With .Rows(1)
.Font.Size = 11
.Interior.Color = 9359529
.BorderAround Weight:=xlThin
.HorizontalAlignment = xlCenter
End With
.Columns(2).NumberFormat = "m/d/yyyy"
.Columns(3).NumberFormat = "m/d/yyyy"
.Columns.ColumnWidth = 18
End With
End With
Set dico = Nothing
Application.ScreenUpdating = True
End Sub
klin89