XL 2021 Repérer des périodes continues avec 2 critères

[ZZELTRON]

Bonjour à tous,

J'ai le problème suivant:

J'ai une liste de Noms avec un code absence et une période (date 1 et date 2).

Chacune des lignes indique donc un nom, un type d'absence et une période. J'aimerais pouvoir repérer et reconstituer les périodes continues pour un même nom et un même code absences. Après recherche sur le forum, je n'ai pas trouvé de solutions à mon problème, y a t il une discussion déjà sur ce problème que je n'aurais pas vu?
Cela est il possible? De préférence par formule, tout est possible pour moi, intégration de colonne supplémentaire, concaténation, formule matricielle...

Je vous joint un fichier exemple pour que cela soit plus clair, avec le tableau initial et ce que j'aimerais repérer.

Merci d'avance pour votre aide

 

[JHA]

Bonjour à tous,

A voir cette méthode sous Power Query.

Trucs et astuces - PowerQuery - Archétypes synergies

JHA

 

[ZZELTRON]

Merci JHA, je regarde.

 

[ZZELTRON]

J'ai bien regardé le lien. Cependant, l exemple donnée concerne des dates uniques pour lesquelles le powerquery permet de créer des périodes continues. Pour mon cas, je pars de périodes. Périodes pour lesquelles je souhaitent ressortir des périodes continues selon 2 critères, le nom et le code absence. Dans l'exemple de powerquery, je n'arrive pas à l'appliquer à des périodes sources. Je ne sais pas si c'est possible avec le powerquery ou autres. Mais , je n'y arrive pas. Merci d'avance pour vos solutions. Cordialement,

 

[Cousinhub]

Bonjour,
Avec Power Query, c'est effectivement possible, mais il faut encoder (et non uniquement "à la souris")...
Sur la base d'une solution donnée par mon ami @Hasco dans ce fil
Si tu n'arrives pas à adapter à ton fichier, joint un fichier ayant exactement la même structure que ton fichier réel sans données confidentielles, évidemment
Bonne journée

 

[job75]

Bonjour ZZELTRON, JHA, Cousinhub, le forum,

Voyez le fichier joint et la macro du bouton :

Sub Grouper()
Dim d As Object, tablo, ub&, i&, x$, n&, a&(), j&, dat&, b&(), nn&
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
tablo = [D6].CurrentRegion.Resize(, 4) 'matrice, plus rapide
ub = UBound(tablo)
ReDim resu(1 To ub, 1 To 4)
For i = 3 To ub
    x = tablo(i, 1) & Chr(1) & tablo(i, 2)
    If Not d.exists(x) Then
        d(x) = ""
        Erase a
        n = 0
        For j = i To ub
            If tablo(j, 1) & Chr(1) & tablo(j, 2) = x Then
                For dat = CLng(tablo(j, 3)) To CLng(tablo(j, 4))
                    ReDim Preserve a(n)
                    a(n) = dat
                    n = n + 1
                Next dat
            End If
        Next j
        tri a, 0, n - 1 'classement des dates
        '---détermination des périodes---
        Erase b
        n = 0
        ReDim Preserve b(0): b(0) = a(0): n = n + 1 '1ère date
        For j = 1 To UBound(a)
            If a(j) > a(j - 1) + 1 Then 'si les dates sont disjointes
                ReDim Preserve b(n): b(n) = a(j - 1): n = n + 1
                ReDim Preserve b(n): b(n) = a(j): n = n + 1
            End If
        Next j
        ReDim Preserve b(n): b(n) = a(UBound(a)) 'dernière date
        '---détermination du tableau des résultats---
        For j = 0 To n Step 2
            nn = nn + 1
            resu(nn, 1) = tablo(i, 1): resu(nn, 2) = tablo(i, 2)
            resu(nn, 3) = b(j): resu(nn, 4) = b(j + 1)
        Next j
    End If
Next i
'---restitution des résultats---
With [L8]
    If nn Then .Resize(nn, 4) = resu
    .Offset(nn).Resize(Rows.Count - nn - .Row + 1, 4).ClearContents 'RAZ en dessous
End With
End Sub

Sub tri(a, gauc, droi) ' Quick sort
Dim ref, g, d, temp
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
    Do While a(g) < ref: g = g + 1: Loop
    Do While ref < a(d): d = d - 1: Loop
    If g <= d Then
      temp = a(g): a(g) = a(d): a(d) = temp
      g = g + 1: d = d - 1
    End If
Loop While g <= d
If g < droi Then Call tri(a, g, droi)
If gauc < d Then Call tri(a, gauc, d)
End Sub

A+

 

[job75]

Le bouton n'est pas nécessaire, on peut utiliser une macro Worksheet_Change.

La fin de la macro :

'---restitution des résultats---
Application.EnableEvents = False 'désactive les évènements
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [L8]
    If nn Then .Resize(nn, 4) = resu
    .Offset(nn).Resize(Rows.Count - nn - .Row + 1, 4).ClearContents 'RAZ en dessous
End With
Application.EnableEvents = True 'réactive les évènements
End Sub

Elle se déclenche quand on modifie ou valide une cellule quelconque.

 

[job75]

Pour tester j'ai recopié le tableau D8:G25 sur 72 000 lignes.

Chez moi la macro s'exécute en 2,4 secondes.

 

[job75]

J'ai ajouté dans les fichiers des posts #6 et #7, en haut du module :

Option Compare Text 'la casse est ignorée