XL 2010 Compter le nombre de valeurs consecutives

Sub Resultat()
Dim F As Worksheet, d As Object, tablo, resu(), i&, x$, n&, lig&
Set F = Tabelle1 'CodeName de la feuille
Set d = CreateObject("Scripting.Dictionary")
If F.FilterMode Then F.ShowAllData 'si la feuille est filtrée
With F.[A1].CurrentRegion
    .Sort .Columns(2), xlAscending, Header:=xlYes 'tri croissant sur les dates
    tablo = .Resize(, 3) 'matrice, plus rapide
End With
ReDim resu(1 To UBound(tablo), 1 To 4)
For i = 2 To UBound(tablo)
    x = LCase(Trim(tablo(i, 1))) 'la casse est ignorée, espaces superflus en A11 et sur Pierre et Jacques
    If x <> "" Then
        If tablo(i, 3) = 1 Then
            If Not d.exists(x) Then
                n = n + 1
                d(x) = n 'mémorise la ligne
                resu(n, 1) = tablo(i, 1)
                resu(n, 2) = tablo(i, 2)
            End If
            lig = d(x) 'restitue la ligne
            resu(lig, 3) = tablo(i, 2)
            resu(lig, 4) = resu(lig, 4) + 1 'comptage
        Else
            If d.exists(x) Then d.Remove x 'retire l'item du Dictionary
        End If
    End If
Next
'---restitution---
With F.[K8] '1ère cellule de destination, à adapter
    If n Then .Resize(n, 4) = resu
    .Offset(n).Resize(F.Rows.Count - n - .Row + 1, 4).ClearContents 'RAZ en dessous
End With
End Sub