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

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

'---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

Option Compare Text 'la casse est ignorée