Formula per contare celle massime consecutive (tramite un valore o colore)

Sub conta()
Dim x, y, w, n1, n2, c, ur, t1, t2
ur = Range("A" & Rows.Count).End(xlUp).Row
Range("Y25:Z34") = ""
c = 3
w = 25
For x = 1 To 10
    t1 = 0
    t2 = 0
    n1 = 0
    n2 = 0
    For y = 3 To ur
        If Cells(y, c + 1) <> "" And Cells(y, c + 1) > 40 Then
            If Cells(y, c + 1) >= 41 And Cells(y, c + 1) <= 45 Then
                n1 = n1 + 1: n2 = 0
                If n1 > t1 Then t1 = t1 + 1 ': Cells(y, 23) = t1
            End If
            If Cells(y, c + 1) >= 46 Then
                n2 = n2 + 1: n1 = 0
                If n2 > t2 Then t2 = t2 + 1 ': Cells(y, 23) = t2
            End If
        End If
    Next
    If t1 > t2 Then Cells(w, 26) = t1 Else Cells(w, 25) = t2
    w = w + 1
    c = c + 2
Next
End Sub