Retraitement des lignes

Coucou Klin89,

Oui je te confirme !

J'ai copié collé le code puis ctrl+F8 et ça me donne un message d'erreur... Peux tu me donner la marche à suivre stp ?

Re rosa14

Vois la disposition obtenue avec ce nouveau code, toujours avec le fichier du 1er post.

Après, tu peux utiliser un TCD ou Powerquery pour obtenir ce que tu souhaites.

Option Explicit
Sub test1()
    Dim a, e, w(), i As Long, ii As Long, n As Long, dico As Object
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    a = Sheets("Absences").Cells(1).CurrentRegion.Value2
    'fusion des périodes
    For i = 2 To UBound(a, 1)
        If Not dico.exists(a(i, 1)) Then
            ReDim w(1 To 5, 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) - 2, UBound(w, 2)) + 1 Then
                w(UBound(w, 1) - 2, 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
    'décompte du nombre de jours par période
    'affectation des tranches
    For Each e In dico.keys
        w = dico.Item(e)
        For i = 1 To UBound(w, 2)
            w(4, i) = w(3, i) - w(2, i) + 1
            Select Case w(4, i)
            Case Is > 30: w(5, i) = "jours > 30"
            Case Is > 3: w(5, i) = "3 < jours " & ChrW(8804) & " 30"
            Case Else: w(5, i) = "jours " & ChrW(8804) & " 3"
            End Select
        Next
        dico.Item(e) = w
    Next
    'restitution dans une nouvelle feuille
    Application.ScreenUpdating = False
    With Sheets.Add
        .Cells(1).Resize(, 5).Value = _
        Array("N° Employé", "Date de début Paye", "Date de fin Paye", "Nbre de jours", "Tranche")
        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 = 52479
                .BorderAround Weight:=xlThin
                .HorizontalAlignment = xlCenter
            End With
            .Columns(2).NumberFormat = "m/d/yyyy"
            .Columns(3).NumberFormat = "m/d/yyyy"
            .Columns(5).HorizontalAlignment = xlCenter
            .Columns.ColumnWidth = 18
        End With
    End With
    Set dico = Nothing
    Application.ScreenUpdating = True
End Sub

klin89

Re rosa14,

Je t'envoie le fichier avec les 2 codes.

Résultat obtenu avec le 1er code :

Résultat obtenu avec le 2ème code :

Cliques sur chacun des boutons pour exécuter les différents codes.

klin89

re rosa14

Une variante avec une autre disposition :

L'exécution est plus longue puisque est restitué un tableau pour chaque employé.

Le nombre de périodes est calculé avec l'introduction d'une formule en fin de chaque tableau :

'calcul du nombre de périodes
With .Cells(4).Resize(, .Columns.Count - 3)
    .FormulaR1C1 = "=counta(r[" & -UBound(dico.Item(e), 2) + 1 & "]c:r[-1]c)"
End With

Le 3ème code :

Option Explicit  :) 
    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 2)
            For ii = 1 To UBound(a, 2) - 1
                w(ii, 1) = a(1, ii)
                w(ii, 2) = a(i, ii)
            Next
            w(4, 1) = "jours " & ChrW(8804) & " 3"
            w(5, 1) = "3 < jours " & ChrW(8804) & " 30"
            w(6, 1) = "jours > 30"
        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 = 2 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
        n = 1
        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))
                With .Rows(.Rows.Count + 1)
                    With .Cells(1)
                        .Value = "Nbre périodes"
                        .HorizontalAlignment = xlCenter
                    End With
                    'Calcul du nombre de périodes
                    With .Cells(4).Resize(, .Columns.Count - 3)
                        .FormulaR1C1 = "=counta(r[" & -UBound(dico.Item(e), 2) + 1 & "]c:r[-1]c)"
                    End With
                    .BorderAround Weight:=xlThin
                End With
                With .CurrentRegion
                    .BorderAround Weight:=xlThin
                    .Borders(xlInsideVertical).Weight = xlThin
                    With .Rows(1)
                        '.Font.Size = 11
                        .HorizontalAlignment = xlCenter
                        .BorderAround Weight:=xlThin
                        .Interior.Color = 7531753
                    End With
                End With
            End With
            n = n + UBound(dico.Item(e), 2) + 2
        Next
        With .UsedRange
            .VerticalAlignment = xlCenter
            .Font.Name = "Calibri"
            .Font.Size = 10
            .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

Illustration de la nouvelle disposition obtenue après exécution du 3ème code :

klin89

Bonjour Klin89,

Olala, tu as fait du bon travail, sincèrement c'est juste top!!!!

Merci encore c'est juste topissime !!!!!!!